Multidimensional Real Analysis, 
             Volumes I and II 
                                 by 

        J.J. Duistermaat and J.A.C. Kolk
         Cambridge University Press, 2004

Mathematica code for illustrations, exercises and additional results 
                                                by 
                                     Johan A.C. Kolk

                                      Contributions by 
                 W.L.J. van der Kallen (UU) and F. Simons (TUE)
                            are gratefully acknowledged

At this moment the project is under construction; the goal is to provide code for: 
●  the illustrations in the books,
●  the exercises in the books,
●  additional computations.      
The input originating from various people at different stages of the project of writing the books, there is (as yet) no uniformity in the construction of the code.

This code has been developed by Kolk under Mathematica 5.1. 
Van der Kallen adapted the code to the current Mathematica 9 by redefining in the initialization cells many commands, whenever this was possible. 
In addition, many modifications on an ad-hoc basis have been made by him. Some directives concerning font sizes or colors have been lost in the process.

Initialization

The cells below are initialization cells. They are evaluated by Mathematica as soon as the notebook is openened.
They address some incompatibility issues.

(* Off[General::"spell"]*)

$ContextPath=Join[{"Init`"},$ContextPath]

We put a limit on the number of plotpoints in some plots, as the values used for the book were very high.

Init`plotPointsPairLimit=40;
Init`plotPoints/:(Init`plotPoints->a_List):=(PlotPoints->(Min[Init`plotPointsPairLimit,#]&/@a))
Init`plotPoints/:(Init`plotPoints->any__):=(PlotPoints->any);
(* 
Init`plotPoints/:(Init`plotPoints->any__):=(PlotPoints->Automatic) 
*)

Init`lightSources/:(Init`lightSources->coldirs__):=(Lighting->(Join[{"Point"},Reverse[#]]&/@coldirs));
Init`defaultFont/:(Init`defaultFont->any_):=(BaseStyle->Large);
(* Init`defaultColor=BaseStyle; *)
Init`show[args__,DisplayFunction->None]:=Show[args];
Init`show[args__,DisplayFunction->$DisplayFunction]:=(Print[Init`pic=Show[args]];Init`pic);
Init`show[args__]:=(Print[Init`pic=Show[args]];Init`pic);
Init`plot[args__,DisplayFunction->None]:=Plot[args];
Init`plot[args__]:=(Print[Init`pic=Plot[args]];Init`pic);
Init`parametricPlot3D[{f_,g_,h_,k_},args__,DisplayFunction->None,more___]:=ParametricPlot3D[{{f,g,h},k},args,more];Init`parametricPlot3D[{f_,g_,h_},args__,DisplayFunction->None,more___]:=ParametricPlot3D[{f,g,h},args,more];Init`parametricPlot3D[args__,DisplayFunction->None]:=ParametricPlot3D[args];
Init`parametricPlot3D[{f_,g_,h_,k_},args__]:=Init`parametricPlot3D[{{f,g,h},k},args];
Init`parametricPlot3D[args__]:=(Print[Init`pic=ParametricPlot3D[args]];Init`pic);Init`parametricPlot[args__,DisplayFunction->None]:=ParametricPlot[args];
Init`parametricPlot[args__]:=(Print[Init`pic=ParametricPlot[args]];Init`pic);
Init`plot3D[args__,DisplayFunction->None]:=Plot3D[args];
Init`plot3D[args__]:=(Print[Init`pic=Plot3D[args]];Init`pic);
Init`contourPlot[args__,DisplayFunction->None]:=ContourPlot[args];
Init`contourPlot[args__]:=ContourPlot[args];
Init`contourPlot3D[args__,DisplayFunction->None]:=ContourPlot3D[args];Init`contourPlot3D[f_,args__]:=ContourPlot3D[f,args, Contours->{0.0}];

A lot of time is wasted on FullSimplify. We kept it active, but one may wish to choose Simplify instead:

Init`fullSimplify=FullSimplify ;
(* Init`fullSimplify=Simplify  *)

(* lightblue=RGBColor[220/256,248/256,248/256];
defaultplotoptions=Sequence[AxesStyle->RGBColor[0,0.5,0], Background->lightbluecolor,ImageSize->400];
SetOptions[ListPlot, Evaluate[defaultplotoptions]];
SetOptions[plot, Evaluate[defaultplotoptions]]; *)

A warning

N[((3Log[640320])/(Sqrt[163]))-π]
((3Log[640320])/(Sqrt[163]))==π
((3Log[640320])/(Sqrt[163]))<π
N[((3Log[640320])/(Sqrt[163]))-π,20]
N[(((E^(π (Sqrt[163])))-744)^(1/3))]
N[(((E^(π (Sqrt[163])))-744)^(1/3)),20]
(((E^(π (Sqrt[163])))-744)^(1/3))<640320
N[(((E^(π (Sqrt[163])))-744)^(1/3)),32]
N[(((((2^(1/3))/((27+3(Sqrt[69]))^(1/3)))+(((27+3(Sqrt[69]))^(1/3))/(3(2^(1/3))))))^27369),5030]-

CHAPTER 1: THEORY

Example 1.3.10  
New Illustration

Off[General::spell1]
lightblue=RGBColor[220/256,248/256,248/256];
rmin=0.005;
rmax=1;
αmin=0;
αmax=2π;
nr=89;
nα=155;
g[x1_,x2_]:=((x1 x2)/((x1^2)+(x2^2)))
x1[r_,α_]:=r Cos[α]
x2[r_,α_]:=r Sin[α]
x3[r_,α_]:=g[x1[r,α],x2[r,α]]

Print["One aspect"]
parametricPlot3D[Append[{x1[r,α],x2[r,α],x3[r,α]},SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{r,rmin,rmax},{α,αmin,αmax},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},Background->lightblue,plotPoints->{nr,nα},ViewPoint->{2,1,1},Boxed->False,Axes->False,Ticks->None,PlotRange->{{-1,1},{-1,1},{-0.5,0.5}},ImageSize->1100];
Print["From a different point of view"]
plot3D[g[x1,x2],{x1,-1,1},{x2,-1,1},plotPoints->171,PlotRange->All,ViewPoint->{1,0,0.8},ColorFunction->Hue,Boxed->False,Axes->None,Background->lightblue,ImageSize->1100];

Examples 1.3.11 and 2.3.3
Illustration

This function g also is studied in Example 2.3.3.

Clear["`*"]
Off[General::spell1]
lightblue=RGBColor[220/256,248/256,248/256];
rmin=0.001;
rmax=1;
αmin=0;
αmax=2π;
nr=89;
nα=155;
g[x1_,x2_]:=((x1 (x2^2))/((x1^2)+(x2^4)))
x1[r_,α_]:=r Cos[α]
x2[r_,α_]:=r Sin[α]
x3[r_,α_]:=g[x1[r,α],x2[r,α]]
parametricPlot3D[Append[{x1[r,α],x2[r,α],x3[r,α]},SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{r,rmin,rmax},{α,αmin,αmax},
lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},PlotPoints->{nr,nα},ViewPoint->{-5,2,3},Boxed->False,Axes->False,Ticks->None,PlotRange->{{-1,1},{-1,1},{-0.5,0.5}},Background->lightblue,ImageSize->1100];

Example 1.7.3

Observe that Mathematica treats the numbers 1.5 and (3/2) differently, they are of the structure Real and Rational, respectively.

Clear["`*"]
f[a_][x_]:=N[(1/2)(x+(a/x)),250]
Print["About (Sqrt[2])"]
FixedPointList[f[2],1.5]
approx=FixedPointList[f[2],(3/2)]
Table[((approx[[k+1]])^2)-2==(1/(4 ((approx[[k]])^2)))(((((approx[[k]])^2)-2))^2),{k,Length[approx]-1}]
Print["Notice the quadratic convergence"]
Table[N[approx[[k]]-(Sqrt[2])],{k,Length[approx]}]
Print["Computation of (Sqrt[163])"]
FixedPoint[f[163],13]
%-N[(Sqrt[163]),250]

CHAPTER 2: THEORY

Example 2.3.5  
New Illustration

Clear["`*"]
g[x1_,x2_]:=((x1 (x2^2))/((x1^2)+(x2^4)))
Together[(∂_(Subscript[x, 1])) g[(Subscript[x, 1]),(Subscript[x, 2])]]
Together[(∂_(Subscript[x, 2])) g[(Subscript[x, 1]),(Subscript[x, 2])]]
Limit[(∂_x1) g[x1,x2]/.{x1->0,x2->t},t->0,Direction->-1]
Limit[(∂_x2) g[x1,x2]/.{x1->t,x2->t},t->0,Direction->-1]

Section 2.4   Chain rule

Using Mathematica we verify the chain rule D(g ◦ f) (x) = Dg(f(x)) ◦ Df(x) from Theorem 2.4.1.

For doing so we note that in Mathematica a vector is just a list, therefore we introduce vectors as variables of the form x_List. In Mathematica  the definition of the Jacobi matrix of a function f at the point x also requires a coordinate system with respect to which the differentiations are performed. This is the symbolic vector y occurring in the following definition. Furthermore, we introduce some short notation for vectors that resembles the usual one.

Clear["`*"]
jacobimatrix[f_,x_List]:= With[{y=Unique[y]&/@x},Table[(∂_(y[[j]])) f[y][[i]],{i,Length[f[y]]},{j,Length[x]}]/. Thread[y->x]]
co[x_,n_]:=Table[(Subscript[x, j]),{j,n}]

We perform some experiments in order to check that our definitions yield the correct results in the case of mappings f : (ℝ^3)→ (ℝ^4)  and g : (ℝ^4)→ (ℝ^2)as defined below. Note that we have g ◦ f :  (ℝ^3)→ (ℝ^2) in this situation

f[{x1_,x2_,x3_}]:={Sin[x1]+Sin[x2]+Sin[x3],Cos[x1]+Cos[x2]+Cos[x3],Tan[x1]+Tan[x2]+Tan[x3],Sin[x1+x2^2+x3^3]}
g[{y1_,y2_,y3_,y4_}]:={y1 y2,y3+y4}
xv=co[x,3]
MatrixForm[f[xv]]
(j1=jacobimatrix[f,xv])//MatrixForm

yv=co[y,4]
MatrixForm[g[yv]]
MatrixForm[jacobimatrix[g,yv]]
(j2=jacobimatrix[g,f[xv]])//MatrixForm

(j3=jacobimatrix[Function[x,g[f[x]]],xv])//MatrixForm

Now we are prepared to check whether the chain rule holds.

j3==j2.j1

We repeat the experiments in order to check that our definitions yield the correct results in the case of mappings f : ℝ→(ℝ^2)  and g : (ℝ^2)→ ℝ as defined in Exercise 2.19. Note that we have g ◦ f :  ℝ→ ℝ in this situation.

f[{t_}]:={Cos[t],Sin[t]}
g[{x1_,x2_}]:={x1^(x2)}
xv={t};
g[f[xv]]//MatrixForm
(j3=jacobimatrix[Function[x,g[f[x]]],xv])//MatrixForm
MatrixForm[f[xv]]
(j1=jacobimatrix[f,xv])//MatrixForm
yv=co[y,2];
MatrixForm[g[yv]]
MatrixForm[jacobimatrix[g,yv]]
(j2=jacobimatrix[g,f[xv]])//MatrixForm
Simplify[j3==j2.j1]

We repeat the experiments in order to check that our definitions yield the correct results in the case of mappings f : (ℝ^2)→ (ℝ^2)  and g : (ℝ^2)→ (ℝ^2)as defined in Exercise 2.20. Note that we have g ◦ f :  (ℝ^2)→ (ℝ^2) in this situation.

f[{x1_,x2_}]:={(x1^2)+(x2^2),Sin[x1 x2]}
g[{x1_,x2_}]:={x1 x2,(E^x2)}
xv=co[x,2];
MatrixForm[g[f[xv]]]
(j3=jacobimatrix[Function[x,g[f[x]]],xv])//MatrixForm
MatrixForm[f[xv]]
(j1=jacobimatrix[f,xv])//MatrixForm
yv=co[y,2];
MatrixForm[g[yv]]
MatrixForm[jacobimatrix[g,yv]]
j2=jacobimatrix[g,f[xv]];
(j2=jacobimatrix[g,f[xv]])//MatrixForm
j3==j2.j1

Section 2.4   Computation of Jacobi determinants

At this stage we have all definitions available for the computation of Jacobi determinants.

jacobidet[f_,x_List]:=Det[jacobimatrix[f,x]]

As a verification, we compute the Jacobi determinant of diffeomorphisms occurring in several examples and exercises.

Off[General::spell1] 
Print["Exercise 3.1"]
map[mapvar_List]:=Block[{y1,y2},{y1,y2}=mapvar;{y1+y2,(y1/y2)}]
mapvar=co[y,2];
map[mapvar]
Simplify[jacobidet[map,mapvar]]

Print["Exercise 3.2.(i)"]
map[mapvar_List]:=Block[{y1,y2},{y1,y2}=mapvar;{y1 y2,(1-y1)y2}]
mapvar=co[y,2];
map[mapvar]
jacobidet[map,mapvar]

Print["Exercise 3.5.(i)"]
map[mapvar_List]:=Block[{x1,x2},{x1,x2}=mapvar;{Cos[x1]Cosh[x2],Sin[x1]Sinh[x2]}]
mapvar=co[x,2];
map[mapvar]
Simplify[jacobidet[map,mapvar]]
Simplify[%+((Sin[mapvar[[1]]])^2)((Cosh[mapvar[[2]]])^2)+((Cos[mapvar[[1]]])^2)((Sinh[mapvar[[2]]])^2)]

Print["Exercises 3.7.(iii), 3.18.(iii) and Example 7.4.11"]
map[mapvar_List]:=Block[{r,α,θ},{r,α,θ}=mapvar;r{Cos[α]Cos[θ],Sin[α]Cos[θ],Sin[θ]}]
mapvar={r,α,θ};
map[mapvar]
Simplify[jacobidet[map,mapvar]]

Print["Exercise 3.11.(iii)"]
map[mapvar_List]:=Block[{y1,y2},{y1,y2}=mapvar;{Sqrt[y1 y2],Sqrt[(1-y1)(y2-1)]}]
mapvar=co[y,2];
map[mapvar]
Simplify[jacobidet[map,mapvar]]

Print["Exercise 3.18.(iii)"]
map[mapvar_List]:=Block[{r,α,θ1,θ2},{r,α,θ1,θ2}=mapvar;r{Cos[α]Cos[θ1]Cos[θ2],Sin[α]Cos[θ1]Cos[θ2],Sin[θ1]Cos[θ2],Sin[θ2]}]
mapvar={r,α,(Subscript[θ, 1]),(Subscript[θ, 2])};
map[mapvar]
Simplify[jacobidet[map,mapvar]]

Print["Exercise 3.19.(iii)"]
map[mapvar_List]:=Block[{y1,y2,y3,y4},{y1,y2,y3,y4}=mapvar;{y1 y2 y3 y4,(1-y1)y2 y3 y4,(1-y2)y3 y4,(1-y3)y4}]
mapvar=co[y,4];
map[mapvar]
jacobidet[map,mapvar]

Print["Exercise 3.20.(ii)"]
map[mapvar_List]:=Block[{y1,y2},{y1,y2}=mapvar;{((Sin[y1])/(Cos[y2])),((Sin[y2])/(Cos[y1]))}]
mapvar=co[y,2];
map[mapvar]
jacobidet[map,mapvar]

Print["Example 6.6.4"]
map[mapvar_List]:=Block[{r,α},{r,α}=mapvar;r{Cos[α],Sin[α]}]
mapvar={r,α};
map[mapvar]
Simplify[jacobidet[map,mapvar]]

Print["Example 6.6.5"]
map[mapvar_List]:=Block[{y1,y2,s},{y1,y2,s}=mapvar;{(1-s)y1,(1-s)y2,s t}]
mapvar={(Subscript[y, 1]),(Subscript[y, 2]),s};
map[mapvar]
Simplify[jacobidet[map,mapvar]]

Print["Example 6.6.7"]
map[mapvar_List]:=Block[{r,α,y3},{r,α,y3}=mapvar;{r Cos[α],r Sin[α],y3}]
mapvar={r,α,(Subscript[y, 3])};
map[mapvar]
Simplify[jacobidet[map,mapvar]]

Print["Example 6.6.8"]
map[mapvar_List]:=Block[{r,t},{r,t}=mapvar;{r  (Subscript[x, 1])[t],r  (Subscript[x, 2])[t]}]
mapvar={r,t};
map[mapvar]
jacobidet[map,mapvar]

Print["Exercise 8.5"]
map[mapvar_List]:=Block[{y1,y2},{y1,y2}=mapvar;{(Subscript[t, 0])+δ y1,((Subscript[t, 0])^2)+2(Subscript[t, 0]) δ y1+(δ^2) y2}]
mapvar=co[y,2];
map[mapvar]
jacobidet[map,mapvar]

Example 2.7.1  
New Illustration

Clear["`*"]
g[x1_,x2_]:=(((x1^2)-(x2^2))/((x1^2)+(x2^2)))
Limit[g[x1,x2],x1->0,Assumptions->{x2≠0}]
Limit[g[x1,x2],x2->0,Assumptions->{x1≠0}]

Notice that the inequality of the mixed partial derivatives at the origin cannot be perceived in the illustration  with the naked eye. In polar coordinates in the plane the qualitative appearance of the surface, in a description as a graph, is immediately Clear.

lightblue=RGBColor[220/256,248/256,248/256];
rmin=0.005;
rmax=3;
αmin=0;
αmax=2π;
nr=69;
nα=155;
f[x1_,x2_]:=x1 x2 g[x1,x2]
x1[r_,α_]:=r Cos[α]
x2[r_,α_]:=r Sin[α]
x3[r_,α_]:=f[x1[r,α],x2[r,α]]

Simplify[x3[r,α]==((r^2)/4)Sin[4α]]
plot3D[f[x1,x2],{x1,-1,1},{x2,-1,1},plotPoints->171,PlotRange->All,ViewPoint->{1,1,0.4},ColorFunction->Hue,Boxed->False,Axes->None,Background->lightblue,ImageSize->1100];

D1f[x1_,x2_]:=x2(((x1^2)-(x2^2))/((x1^2)+(x2^2)))+4x2(((x1^2)(x2^2))/((((x1^2)+(x2^2)))^2))
D2f[x1_,x2_]:=x1(((x1^2)-(x2^2))/((x1^2)+(x2^2)))-4x1(((x1^2)(x2^2))/((((x1^2)+(x2^2)))^2))
Simplify[(∂_x1)f[x1,x2]==D1f[x1,x2]]
Simplify[(∂_x2)f[x1,x2]==D2f[x1,x2]]
D1f[0,(Subscript[x, 2])]
D2f[(Subscript[x, 1]),0]
(∂_x2)D1f[0,x2]/.x2->0
(∂_x1)D2f[x1,0]/.x1->0
%%==%
Simplify[(∂_x2)D1f[x1,x2]/.{x1->r Cos[ϕ],x2->r Sin[ϕ]}]

Example 2.9.9   
Illustration

Clear["`*"]
f[x1_,x2_]:=x1 x2-(x1^2)-(x2^2)-2x1-2x2+4;
g1=contourPlot[f[x1,x2],{x1,-4,0},{x2,-4,0},plotPoints->Automatic, Contours->100,plotPoints->300, ColorFunction->Hue,Ticks->None, Frame->False,DisplayFunction->None];
g2=Graphics[{Thickness[0.002],Line[{{-2,-2},{-1.25,-1.25}}]}]; 
g3=Graphics[{Thickness[0.002],Line[{{-2,-2},{-2-1/(1.66Sqrt[2]),-2+1/(1.66Sqrt[2])}}]}];
show[g1,g2, g3,ImageSize->700,DisplayFunction->$DisplayFunction];

The color indicates the level. Notice that the function f changes slowly near its maximum at –(2,2).

Example 2.10.8   (Frullani's integral)  
New Illustration

Clear["`*"]
Integrate[(((x^b)-(x^a))/(Log[x])),{x,0,1},Assumptions->{a>0,b>a}]
Integrate[(((E^(-a t))-(E^(-b t)))/t),{t,0,∞},Assumptions->{a>0,b>a}]

Example 2.10.14   
New Illustration

Clear["`*"]
Integrate[((Sin[t])/t),{t,0,∞}]
Integrate[(E^(-x t))((Sin[t])/t),{t,0,∞},Assumptions->{x>0}]
Simplify[(∂_x) (%+ArcTan[x])]
%%+ArcTan[x]/.x->1

Example 2.10.16  
New Illustration

Clear["`*"]
Integrate[(E^(-p y))((Cos[a y]-Cos[b y])/y),{y,0,∞},Assumptions->{p>0,a>0,b>0}]
Integrate[((Cos[a y]-Cos[b y])/y),{y,0,∞},Assumptions->{a>0,b>0}]

CHAPTER 3: THEORY

Example 3.1.1   (Polar coordinates)   
New Illustrations

In the first illustration the radial variable is rendered in exponential form. The second illustration is also useful in Exercises 0.1 and 5.36.

The following is time-consuming.

Clear["`*"];
gridImage::usage:="gridImage[f,{x,xmin,xmax,xdi},{y,ymin,ymax,ydi}] plots the image under a complex function f of the grid with mesh widths given by xdi, ydi." 
?gridImage
gridImage[f_,{x_,xmin_,xmax_,xdi_},{y_,ymin_,ymax_,ydi_},opts___Rule]:=
Module[{gr},gr=Union[
Table[{Hue[0.1+0.9(x-xmin)/(xmax-xmin)],Cases[ParametricPlot[f,{y,ymin,ymax},PlotPoints->200,DisplayFunction->None],_Line,Infinity]},{x,xmin,xmax,xdi}],
Table[{Hue[0.1+0.9(y-ymin)/(ymax-ymin)],Cases[ParametricPlot[f,{x,xmin,xmax},PlotPoints->200,DisplayFunction->None],_Line,Infinity]},{y,ymin,ymax,ydi}]];
show[Graphics[gr,opts,AspectRatio->Automatic,PlotRange->All,Axes->True,ImageSize->801]]]
                                                          toCart[z_]:={Re[z],Im[z]}
complexListGridplot[f_List,more__]:=gridImage[toCart[#],more]&/@f
                                                        par[r_,a_]:=r Exp[I a]
f[z_]:=(E^z)
complexListGridplot[{{x,y},f[x+I y]},{x,-2,2,0.01}, {y,-π,π,0.01},Ticks->None,Axes->False];

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
p[α_]:={Cos[α],Sin[α]}
q[α_]:={-1,0}+0.2p[α]
p1=parametricPlot[p[α],{α,-π,π},PlotStyle->darkblue,DisplayFunction->None];
p2=parametricPlot[0.2p[α],{α,0,π/3.5},PlotStyle->RGBColor[1,0,0],DisplayFunction->None];
p3=parametricPlot[0.22p[α],{α,0,π/3.5},PlotStyle->RGBColor[1,0,0],DisplayFunction->None];
p4=parametricPlot[q[α],{α,0,π/7},PlotStyle->RGBColor[1,0,0],DisplayFunction->None];
p5=Graphics[{darkblue,PointSize[0.02],Point[0p[0]],Point[p[π]],Point[p[π/3.5]]}];
p6=Graphics[{darkblue,Line[{p[π],p[π/3.5],0p[0],p[0],p[π]}]}];
show[p1,p2,p3,p4,p5,p6,Axes->False,Ticks->None,AspectRatio->Automatic,Background->lightblue,ImageSize->400,DisplayFunction->$DisplayFunction];

In Mathematica the functions Re, Im and Arg are numerical, which makes these unfit for use in symbolic computations. Therefore new, mathematical, versions of these functions are introduced.

Clear["`*"]
Off[General::spell1]
fullSimplify[Arg[(E^(I α))],{-π<α<π,Im[α]==0}]
Simplify[Arg[Cos[α]+I Sin[α]],{-π<α<π,Im[α]==0}]

re[z_]:=(1/2)(z+Conjugate[z])
im[z_]:=(1/(2I))(z-Conjugate[z])
arg[z_]:=2ArcTan[im[z]/((Sqrt[((re[z])^2)+((im[z])^2)])+re[z])]
Simplify[r (E^(I α)),{r>0,Im[α]==0}]
Simplify[Conjugate[r (E^(I α))],{r>0,Im[α]==0}]
fullSimplify[re[(E^(I α))],Im[α]==0]
fullSimplify[im[(E^(I α))],Im[α]==0]
Simplify[arg[x+I y],{Im[x]==0,Im[y]==0}]
fullSimplify[arg[(E^(I α))],{-π<α<π,Im[α]==0}]

Simplify[Sin[α]/(1+Cos[α])]

Example 3.3.A 
Illustration

Formulae have been added by means of Xfig.

Clear["`*"];
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
R[a_]:={{Cos[a],Sin[a]},{-Sin[a],Cos[a]}}
arrow[x_,y_,h_,b_,a_]:=Polygon[{R[a].{-2 b,-2 h}+{x,y},R[a].{0,2 h}+{x,y},R[a].{2 b,-2 h}+{x,y},R[a].{0,-h}+{x,y}}]
plot[0.5/x,{x,0.5,3.5},             PlotPoints->50,PlotStyle->{RGBColor[1,0,0],AbsoluteThickness[0.5]},DisplayFunction->None];
plot[2/x,{x,1.25,3.75},             PlotPoints->50,PlotStyle->{RGBColor[1,0,0],AbsoluteThickness[0.5]},DisplayFunction->None];
plot[Sqrt[x^2-1],{x,1,2},       PlotPoints->50,PlotStyle->{RGBColor[1,0,0],AbsoluteThickness[0.5]},DisplayFunction->None];
plot[Sqrt[x^2-9],{x,3,3.25},PlotPoints->50,PlotStyle->{RGBColor[1,0,0],AbsoluteThickness[0.5]},DisplayFunction->None];
plot[Sqrt[x^2-1],{x,Sqrt[0.5+0.5 Sqrt[2]],  Sqrt[0.5+0.5 Sqrt[17]]},PlotPoints->50,PlotStyle->{RGBColor[1,0,0],AbsoluteThickness[1.75]},DisplayFunction->None];
plot[Sqrt[x^2-9],{x,Sqrt[4.5+0.5 Sqrt[82]],Sqrt[4.5+0.5 Sqrt[97]]},PlotPoints->50,PlotStyle->{RGBColor[1,0,0],AbsoluteThickness[1.75]},DisplayFunction->None];
plot[0.5/x,{x,Sqrt[0.5+0.5 Sqrt[2]],Sqrt[4.5+0.5 Sqrt[82]]},PlotPoints->50,PlotStyle->{RGBColor[1,0,0],AbsoluteThickness[1.75]},DisplayFunction->None];
plot[2/x,  {x,Sqrt[0.5+0.5 Sqrt[17]],Sqrt[4.5+0.5 Sqrt[97]]},PlotPoints->50,PlotStyle->{RGBColor[1,0,0],AbsoluteThickness[1.75]},DisplayFunction->None];
Graphics[{Text["A",{0.5,1.2}],Text["B",{1,1.7}],Text["C",{2.1,1.7}],Text["D",{3,1.4}],Text["U",{2,0.5}]},DisplayFunction->None];
p1=show[%%%%%%%%%,%%%%%%%%,%%%%%%%,%%%%%%,%%%%%,%%%%,%%%,%%,%,AspectRatio->0.8,AxesStyle->RGBColor[0,0.5,0],Ticks->{{1,3},{1}},PlotRange->{-0.6,2},Background->lightblue,BaseStyle->Medium,DisplayFunction->None];Show[p2=Graphics[{RGBColor[0,0.5,0],{AbsoluteThickness[0.5],Line[{{-4,2.5},{-1.5,2.5}}],Line[{{-1,0},{10,0}}],Line[{{0,-1},{0,5}}]},{RGBColor[1,0,0],AbsoluteThickness[0.5],Line[{{0.5,1},{9.5,1}}],Line[{{0.5,4},{9.5,4}}],Line[{{1,0.5},{1,4.5}}],Line[{{9,0.5},{9,4.5}}]},{darkblue,arrow[-1.5,2.5,0.2,0.1,0.5 π]},{RGBColor[1,0,0],AbsoluteThickness[1.75],Line[{{1,1},{9,1},{9,4},{1,4},{1,1}}]},
Text[Style["V",Black],{5,2.5}],Text["1",{1,-0.6}],Text["9",{9,-0.6}],Text["1",{-0.45,1}],Text["4",{-0.45,4}]}],   PlotRange->{{-4,10},{-1,5}},Background->lightblue,DisplayFunction->Identity];GraphicsGrid[{{p1,p2}},Alignment->{{Right,Left}},Background->lightblue,ImageSize->900,BaseStyle->Large,DisplayFunction->$DisplayFunction]

Example 3.3.B 
Illustration

Formulae have been added by means of Xfig.

Clear["`*"];
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
t=0.75 π;
d=0.15 π;
R[a_]:={{Cos[a],Sin[a]},{-Sin[a],Cos[a]}}
arrow[x_,y_,h_,b_,a_]:=Polygon[{R[a].{-2 b,-4 h}+{x,y},{x,y},R[a].{2 b,-4 h}+{x,y},R[a].{0,-3 h}+{x,y}}]
Graphics[{Text["x(s)",{2 Cos[t],Sin[t]},{1.5,-1.5},BaseStyle->{Black,Medium}],Text["Dx(s)",{-2 Sin[t],Cos[t]},{1,2},BaseStyle->{Black,Medium}],Text["0",{0,0},{-4,1},BaseStyle->{Black,Medium}],Circle[{0,0},{2,1},{0.4 π,1.2 π}],{AbsoluteThickness[2],Line[{{0,0},{2 Cos[t],Sin[t]}}],Line[{{0,0},{-2 Sin[t],Cos[t]}}]},{AbsoluteThickness[1],Line[{{0,0},{2 Cos[t+d],Sin[t+d]}}],Line[{{0,0},{2 Cos[t-d],Sin[t-d]}}],Table[Circle[{0,0},{2 r/10,r/10},{t-d,t+d}],{r,1,10}]},arrow[2 Cos[t],Sin[t],0.025,0.025,ArcTan[t-0.5 π]-0.55 π],arrow[-2 Sin[t],Cos[t],0.025,0.025,ArcTan[t]+π]},BaseStyle->{Red,Small},Background->lightblue,AspectRatio->Automatic];
show[%,BaseStyle->{Red},ImageSize->500];

Clear["`*"];
a[t_]:=ArcTan[(((Subscript[x, 2])[t])/((Subscript[x, 1])[t]))]
Simplify[(∂_t) a[t]]
aa[t_]:=2ArcTan[(((Subscript[x, 2])[t])/((Sqrt[(((Subscript[x, 1])[t])^2)+(((Subscript[x, 2])[t])^2)])+(Subscript[x, 1])[t]))]
fullSimplify[(∂_t) aa[t]]

Application 3.6.B

Clear["`*"]
Off[General::spell1]
jacobimatrix[f_,x_List]:=With[{y=Unique[y]&/@x},Table[(∂_(y[[j]])) f[y][[i]],{i,Length[f[y]]},{j,Length[x]}]/. Thread[y->x]]
 co[x_,n_]:=Table[(Subscript[x, j]),{j,n}]
Unprotect[Power];
Format[Power[Subscript[x_,y_],z_]]:=DisplayForm[SuperscriptBox[SubscriptBox[x,y],z]]

f[x_,y_List]:=(x^2)y[[1]]+(E^(2x))+y[[2]]
yv=co[y,2]
f[x,yv]
x0=0;
y0={1,-1};
f[x0,y0]
Dxf=(∂_x) f[x,y0]/.x->x0
fx[y_List]:={f[x0,y]}
fx[yv]
Dyf=jacobimatrix[fx,y0];
MatrixForm[Dyf]
MatrixForm[-Dxf^(-1)Dyf]
fy[y1_,y2_]:=f[x[y1,y2],{y1,y2}]
Dy1f=(∂_y1) fy[y1,y2];
Dy2f=(∂_y2) fy[y1,y2];
Dy1f/.{Derivative[1,0][x][y1,y2]->"((Subscript[D, 1])x)",x[y1,y2]->x,y1->(Subscript[y, 1])}
Dy2f/.{Derivative[0,1][x][y1,y2]->"((Subscript[D, 2])x)",x[y1,y2]->x,y1->(Subscript[y, 1])}
Flatten[Solve[Dy1f==0,Derivative[1,0][x][y1,y2]]/.{Derivative[1,0][x][y1,y2]->"(Subscript[D, 1])x(1,-1)",x[y1,y2]->0,y1->1,y2->-1},2]
rule=First[Flatten[Solve[Dy2f==0,Derivative[0,1][x][y1,y2]]/.{Derivative[0,1][x][y1,y2]->"(Subscript[D, 2])x(1,-1)",x[y1,y2]->0,y1->1,y2->-1},2]];rule[[1]]<>" = "<>ToString[InputForm[(rule[[2]])]]
Dyy2f=(∂_(y2,y2))fy[y1,y2];
Dyy2f/.{Derivative[0,2][x][y1,y2]->"(((Subscript[D, 2])^2)x)",Derivative[0,1][x][y1,y2]->"((Subscript[D, 2])x)",x[y1,y2]->x,y1->(Subscript[y, 1])}
rule=First[Flatten[Solve[Dyy2f==0,Derivative[0,2][x][y1,y2]]/.{Derivative[0,2][x][y1,y2]->"((Subscript[D, 2])^2)x(1,-1)",Derivative[0,1][x][y1,y2]->-1/2,x[y1,y2]->0,y1->1,y2->-1},2]];rule[[1]]<>" = "<>ToString[InputForm[(rule[[2]])]]

CHAPTER 4: THEORY

Section 4.1   Introductory remarks

Clear["`*"]
Off[General::spell1]
lightblue=RGBColor[220/256,248/256,248/256];
Print[Helix]
view={18,3,0.5};
parametricPlot3D[Append[{w,Cos[w],Sin[w]},RGBColor[1,0,0]]//Evaluate,{w,-6.1π,7.3π},AxesStyle->RGBColor[0,0.5,0],PlotRange->All,ColorFunction->(Red&),AspectRatio->1,Boxed->False,Ticks->None,AxesEdge->{{-1,-1},{-1,-1},{-1,-1}},plotPoints->200,ViewPoint->view,Background->lightblue,ImageSize->500];

Print["Ellipse, hyperbola and parabola"]

p1=contourPlot[((x1^2)/5)+((x2^2)/2)==1,{x1,-3,3},{x2,-3,3},Ticks->None,ColorFunction->(Red&),AxesStyle->RGBColor[0,0.5,0],Background->lightblue,DisplayFunction->None];
p2=contourPlot[((x1^2)/3)-((x2^2)/2)==1,{x1,-5,5},{x2,-3,3},Ticks->None,ColorFunction->(Red&),AxesStyle->RGBColor[0,0.5,0],Background->lightblue,DisplayFunction->None];
p3=contourPlot[(x1/3)+((x2^2)/2)==1,{x1,-1,3},{x2,-3,3},Ticks->None,ColorFunction->(Red&),AxesStyle->RGBColor[0,0.5,0],Background->lightblue,DisplayFunction->None];
show[GraphicsGrid[{{p1,p2,p3}}],ImageSize->1200,DisplayFunction->$DisplayFunction];

Print["Example of nondegenerate quadric: one-sheeted hyperboloid ((Subscript[x, 1])^2)+((Subscript[x, 2])^2)-((Subscript[x, 3])^2)=1"]
x1[α_,t_]:=Cosh[t]Cos[α]
x2[α_,t_]:=Cosh[t]Sin[α]
x3[α_,t_]:=Sinh[t]
Simplify[((x1[α,t])^2)+((x2[α,t])^2)-((x3[α,t])^2)]
x[α_,t_]:={x1[α,t],x2[α,t],x3[α,t]};
view={2,2,1};
h=parametricPlot3D[Append[x[α,t],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{α,-π,π},{t,-1.5,1.5},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},plotPoints->{121,121},Axes->False,PlotRange->All,BoxRatios->{1,1,1},Boxed->False,Background->lightblue,PlotRange->All,Axes->False,BoxRatios->{1,1,1},AspectRatio->1,Boxed->False,ViewPoint->view,ImageSize->800]; 

Print["Example of nondegenerate quadric: elliptic paraboloid -((Subscript[x, 1])^2)-((Subscript[x, 2])^2)+(Subscript[x, 3])=0"]
x1[α_,t_]:=t Cos[α]
x2[α_,t_]:=t Sin[α]
x3[α_,t_]:=(t^2)
Simplify[-((x1[α,t])^2)-((x2[α,t])^2)+x3[α,t]]
x[α_,t_]:={x1[α,t],x2[α,t],x3[α,t]};
view={2,2,1};
h=parametricPlot3D[Append[x[α,t],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{α,-π,π},{t,0,3},lightSources->{{{2,0,0},RGBColor[1,0,0]},{{2,0,0},RGBColor[1,0,0]},{{-2,0,0},RGBColor[1,0,0]},{{0,2,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},plotPoints->{121,121},Axes->False,PlotRange->All,BoxRatios->{1,1,1},Boxed->False,Background->lightblue,AspectRatio->1,Boxed->False,ViewPoint->view,ImageSize->800]; 

Print["Example of nondegenerate quadric: hyperbolic paraboloid ((Subscript[x, 1])^2)-((Subscript[x, 2])^2)+(Subscript[x, 3])=0"]

contourPlot3D[(x1^2)-(x2^2)+x3,{x1,-4,4},{x2,-4,4},{x3,-4,4},PlotPoints->9,PlotRange->{{-3,3},{-2,2},{-2,2}},ViewPoint->{2,1.4,1.6},
ContourStyle->RGBColor[0.7,0.7,1],lightSources->{{{1,0,0},RGBColor[0,0,1]},{{0,1,0},RGBColor[0,0,1]},{{0,2,2},RGBColor[0,1,1]}},Background->lightblue,Boxed->False,ImageSize->800]

Definition 4.2.1
Illustration

This has been produced using Xfig.

Section 4.3   Immersion Theorem

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
r=3;
s=1.2;
t0=0.16 π;
t1=0.35 π;
t3=0.22 π;
t4=0.27 π;
x=0.1;
R[a_]:={{Cos[a],Sin[a]},{-Sin[a],Cos[a]}}
arrow[x_,y_,h_,b_,a_]:=Polygon[{R[a].{-2 b,-2 h}+{x,y},R[a].{0,2 h}+{x,y},R[a].{2 b,-2 h}+{x,y},R[a].{0,-h}+{x,y}}]

p1=parametricPlot[{r Cos[t],1+s Sin[t]},{t,-0.2 π,0.4 π},PlotPoints->50,PlotStyle->AbsoluteThickness[1],DisplayFunction->None];
p2=parametricPlot[{r Cos[t],1+s Sin[t]},{t,t0,t1},PlotPoints->50,PlotStyle->AbsoluteThickness[2],DisplayFunction->None];
p3=Graphics[{{AbsolutePointSize[5],Point[{r Cos[t4],0.6}],Point[{r Cos[t3],1+s Sin[t3]}],Point[{r Cos[t4],1+s Sin[t4]}]},{AbsoluteThickness[1],Dashing[{0.01,0.01}],Line[{{r Cos[t4],0.6},{r Cos[t4],1+s Sin[t4]},{0.5,1+s Sin[t4]}}]},{AbsoluteThickness[3],Line[{{r Cos[t0],0.6},{r Cos[t1],0.6}}]},{AbsoluteThickness[1],Line[{{0.25,0.6},{3.2,0.6}}],Line[{{0.5,0.4},{0.5,2.4}}]}}];
p4=Graphics[{{AbsolutePointSize[5],Point[{4.9,0.6}]},{AbsoluteThickness[3],Line[{{4.25,0.6},{5.5,0.6}}]},{AbsoluteThickness[1],Line[{{4,0.4},{4,2.4}}],Line[{{3.75,0.6},{6,0.6}}]}}];
p5=Graphics[{{AbsolutePointSize[4],Point[{2.25,-0.75}]},{AbsolutePointSize[6],Point[{3,-0.75}],Point[{3.5,-0.75}]},{AbsoluteThickness[3],Line[{{2.5,-0.75},{4,-0.75}}]},{AbsoluteThickness[1],Line[{{1.5,-0.75},{1.965,-0.75}}],Line[{{2.035,-0.75},{4.465,-0.75}}],Line[{{4.535,-0.75},{5,-0.75}}],Circle[{2,-0.75},0.035],Circle[{4.5,-0.75},0.035]}}];
p6=Graphics[{{AbsoluteThickness[1],Line[{{3,1.5},{3.75,1.15}}],Line[{{2.25,0.25},{2.75,-0.4}}],Line[{{2.6,0.2},{2.9,-0.5}}]},arrow[3.75,1.15,0.04,0.03,0.5 π+ArcTan[0.35/0.65]],arrow[2.75,-0.4,0.04,0.03,0.5 π+ArcTan[0.65/0.5]],arrow[2.6,0.2,0.04,0.03,ArcTan[0.7/0.3]-0.5 π]}];
p7=Graphics[{Text["a",{2.25,-1}],Text["b",{3,-1}],Text["c",{3.5,-1}],Text["d",{3.6,-0.5}],Text["e",{4.3,-0.5}],Text["f",{5.5,-0.75}],Text["g",{3.7,0.4}],Text["h",{4.95,0.4}],Text["i",{6,0.4}],Text["j",{4.2,2.3}],Text["k",{0.3,0.4}],Text["l",{0.4,1.9}],Text["m",{0.6,2.3}],Text["n",{1.5,0.75}],Text["o",{2,0.4}],Text["p",{3.1,1}],Text["q",{2.4,1.9}],Text["r",{2,2.1}],Text["s",{3.4,0.4}],Text["t",{3.5,1.5}],Text["u",{2.4,-0.3}],Text["v",{3,0}]}];
show[p1,p2,p3,p4,p5,p6,p7,PlotRange->{{0.2,6.2},{-1,2.4}},AxesOrigin->{1,0.6},Axes->None,AspectRatio->Automatic,Background->lightblue,BaseStyle->Medium,ImageSize->900,DisplayFunction->$DisplayFunction];

Corollary 4.3.2 
Illustration

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
R[a_]:={{Cos[a],Sin[a]},{-Sin[a],Cos[a]}}
arrow[x_,y_,h_,b_,a_]:=Polygon[{R[a].{-2 b,-4 h}+{x,y},{x,y},R[a].{2 b,-4 h}+{x,y},R[a].{0,-3 h}+{x,y}}]
r0=2;
s0=1;
r[t_]:=r0+2 (E^(-(t^2)))
s[t_]:=s0+3 (E^(-t))
t0=2.8 π;
t1=0.925 π;
p1=parametricPlot[{-r[t] Cos[t]-Sin[t],-s[t] Sin[t]},{t,-0.4 π,t0},PlotStyle->RGBColor[1,0,0],DisplayFunction->None];
p2=parametricPlot[{-r[t] Cos[t]-Sin[t],-s[t] Sin[t]},{t,2.75 π,2.9 π},PlotStyle->{RGBColor[1,0,0],Dashing[{0.01,0.01}]},DisplayFunction->None];
p3=Graphics[{{darkblue,Line[{{-4.5,-3.5},{2.5,-3.5}}]},{darkblue,Line[{{1,-1.5},{0.1,-2.85}}]},{darkblue,AbsolutePointSize[5],Point[{-r[t0] Cos[t0]-Sin[t0],-s[t0] Sin[t0]}],Point[{-r[t1] Cos[t1]-Sin[t1],-s[t1] Sin[t1]}],Point[{-3,-3.5}],Point[{2,-3.5}]},{darkblue,arrow[0,-3,0.075,0.05,ArcTan[-1.5]-0.5 π]},Text["a",{-r[t0] Cos[t0]-Sin[t0],-s[t0] Sin[t0]}],Text["b",{-r[t1] Cos[t1]-Sin[t1],-s[t1] Sin[t1]}],Text["c",{-3,-3.5}],Text["d",{2,-3.5}],Text["e",{0,-3}]}];
show[p1,p2,p3,AspectRatio->1,Axes->None,PlotRange->{-4,3},BaseStyle->Large,Background->lightblue,ImageSize->400,DisplayFunction->$DisplayFunction];

Example 4.4.2 
Illustration

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
φ[t_]:={(t^2)-1,(t^3)-t}
R[a_]:={{Cos[a],Sin[a]},{-Sin[a],Cos[a]}}
arrow[x_,y_,h_,b_,a_]:=Polygon[{R[a].{-2 b,-4 h}+{x,y},{x,y},R[a].{2 b,-4 h}+{x,y},R[a].{0,-3 h}+{x,y}}];
p1=parametricPlot[φ[t],{t,-2,1},PlotStyle->{RGBColor[1,0,0],AbsoluteThickness[1.5]},AspectRatio->Automatic,PlotPoints->50,Ticks->None,PlotRange->{{-1.5,1.5},{-1,1}},Background->lightblue,DisplayFunction->None];
p2=parametricPlot[φ[t],{t,1,2},PlotStyle->{RGBColor[1,0,0],Dashing[{0.025,0.025}]},AspectRatio->Automatic,PlotPoints->50,Ticks->None,PlotRange->{{-1.5,1.5},{-1,1}},Background->lightblue,DisplayFunction->None];
p3=Graphics[{darkblue,{arrow[0,0,0.03,0.025,0.25 π],arrow[0.5,-Sqrt[3/2]^3+Sqrt[3/2],0.03,0.025,-0.175 π]}},Background->lightblue,DisplayFunction->None];
show[p1,p2,p3,AxesStyle->RGBColor[0,0.5,0],ImageSize->600,DisplayFunction->$DisplayFunction];

Example 4.4.3   (Torus) 
Illustration

Missing. p343V

Section 4.5   Submersion Theorem

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
f[t_,c_]:=-0.75 (((t-1))^2)+c
R[a_]:={{Cos[a],Sin[a]},{-Sin[a],Cos[a]}}
arrow[x_,y_,h_,b_,a_]:=Polygon[{R[a].{-2 b,-2 h}+{x,y},R[a].{0,2 h}+{x,y},R[a].{2 b,-2 h}+{x,y},R[a].{0,-h}+{x,y}}]
t0=2.89297;
t1=3.75379;
t2=1.25;
t3=3.01556;
c0=-3.15;
c=-2.6;
y0=2.4;
y=3;
p1=parametricPlot[{f[t,6],t-0.5},{t,-0.15,2.65201},PlotPoints->200,PlotStyle->{AbsoluteThickness[0.75]},DisplayFunction->None];
p2=parametricPlot[{f[t,6],t-0.5},{t,2.65201,3.5},PlotPoints->200,PlotStyle->{AbsoluteThickness[2]},DisplayFunction->None];
p3=parametricPlot[{f[t,6],t-0.5},{t,3.5,3.65},PlotPoints->200,PlotStyle->{AbsoluteThickness[0.75]},DisplayFunction->None];
p4=parametricPlot[{f[t,4.5],t-0.5},{t,-0.15,1.8539},PlotPoints->200,PlotStyle->{AbsoluteThickness[0.75]},DisplayFunction->None];
p5=parametricPlot[{f[t,4.5],t-0.5},{t,1.8539,3.06156},PlotPoints->200,PlotStyle->{AbsoluteThickness[2]},DisplayFunction->None];
p6=parametricPlot[{f[t,4.5],t-0.5},{t,3.06156,3.3},PlotPoints->200,PlotStyle->{AbsoluteThickness[0.75]},DisplayFunction->None];
p7=parametricPlot[{f[t,7],t-0.5},{t,t3,t1},PlotPoints->200,PlotStyle->{AbsoluteThickness[0.75]},DisplayFunction->None];
p8=parametricPlot[{f[t,4],t-0.75},{t,t2,t0},PlotPoints->200,PlotStyle->{AbsoluteThickness[0.75]},DisplayFunction->None];
p9=Graphics[{{AbsoluteThickness[0.5],Line[{{-1,0},{6.5,0}}],Line[{{0,-0.5},{0,3.75}}]},{AbsoluteThickness[0.75],Line[{{f[t0,4],t0-0.75},{f[t1,7],t1-0.5}}],Line[{{f[t2,4],t2-0.75},{f[t3,7],t3-0.5}}]},{AbsoluteThickness[0.75],Dashing[{0.01,0.01}],Line[{{y,0},{y,2.5}}],Line[{{y0,0},{y0,2.17332}}],Line[{{0,2.5},{y,2.5}}],Line[{{0,2.17332},{y0,2.17332}}]}}];
p10=show[p1,p2,p3,p4,p5,p6,p7,p8,p9,PlotRange->{{-1.5,10},{-6,4}},Axes->None,AspectRatio->0.7,DisplayFunction->None];
p11=Graphics[{{AbsoluteThickness[0.5],Line[{{-1,-5},{6.5,-5}}],Line[{{0,-5.5},{0,-1.5}}]},{AbsoluteThickness[0.75],Line[{{f[t0,4],-3.75},{f[t1,7],-2.25},{f[t3,7],-2.25},{f[t2,4],-3.75},{f[t0,4],-3.75}}]},{AbsoluteThickness[2],Line[{{f[t0,4],c0},{f[t2,4],c0}}],Line[{{f[t0,4],c},{f[t2,4],c}}]},{AbsoluteThickness[0.75],Dashing[{0.01,0.01}],Line[{{0,c0},{f[t0,4],c0}}],Line[{{0,c},{f[t0,4],c}}],Line[{{y0,-5},{y0,c0}}],Line[{{y,-5},{y,c}}]}}];
p12=Graphics[{{AbsoluteThickness[0.5],Line[{{8,-1.5},{8,-5.5}}]},{AbsoluteThickness[2],Line[{{8,-3.75},{8,-2.25}}]},{AbsolutePointSize[4],Point[{8,-5}]},{AbsolutePointSize[5],Point[{8,c0}],Point[{8,c}]}}];
p13=Graphics[{{AbsoluteThickness[0.75],Line[{{5.5,(c+c0)/2},{7,(c+c0)/2}}],Line[{{y,-1.8},{y,-0.8}}],Line[{{2.52941,-1.8},{1.94118,-0.8}}],Line[{{6,-0.56},{7,-1.58}}]},arrow[7,(c+c0)/2,0.075,0.05,π/2],arrow[7,-1.58,0.075,0.05,ArcTan[5.1/5]+π/2],arrow[y,-0.8,0.075,0.05,0],arrow[1.94118,-0.8,0.075,0.05,ArcTan[5.1/3]-π/2],Text["a",{0.5,-4.75}],Text["b",{y0,-5.3}],Text["c",{y,-5.3}],Text["d",{7,-5}],Text["e",{4.5,-3.5}],Text["f",{y,-2.5}],Text["g",{-0.5,c0}],Text["h",{-0.5,c}],Text["i",{8.5,-5}],Text["j",{8.5,-3.6}],Text["k",{8.5,c0}],Text["l",{8.5,c}],Text["m",{8,-1.5}],Text["n",{6.8,c0}],Text["o",{6.8,-2}],Text["p",{5,1}],Text["q",{3.5,-1}],Text["r",{1.8,-1.5}],Text["s",{0.5,0.25}],Text["t",{y0,-0.3}],Text["u",{y,-0.3}],Text["v",{7,0}],Text["w",{6,1}],Text["x",{3.45,2}],Text["y",{2.5,1.8}],Text["z",{-0.5,2.2}],Text["za",{-0.5,2.5}],Text["zb",{0,4}]}];
show[p10,p11,p12,p13,PlotRange->{{-1.5,10},{-6,4.5}},Axes->None,AspectRatio->1,Background->lightblue,BaseStyle->Medium,ImageSize->900,DisplayFunction->$DisplayFunction];

Example 4.6.3   (Torus)

Clear["`*"]
Off[Eliminate::ifun]

lightblue=RGBColor[220/256,248/256,248/256];
sol=Eliminate[{(Subscript[x, 1])==(2+Cos[θ])Cos[α],(Subscript[x, 2])==(2+Cos[θ])Sin[α],(Subscript[x, 3])==Sin[θ]},{α,θ}]
Simplify[sol[[1]]]
Expand[sol[[2]]]
g[x1_,x2_,x3_]:=((((x1^2)+(x2^2)+(x3^2)-5))^2)+16((x3^2)-1)
Expand[g[(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])]]
Solve[{(∂_(Subscript[x, 1])) g[(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])]==0,(∂_(Subscript[x, 2])) g[(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])]==0,(∂_(Subscript[x, 3])) g[(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])]==0,g[(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])]==0},{(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])}]/.{Rule->Equal}
contourPlot3D[g[x1,x2,x3],{x1,-3,3},{x2,-3,3},{x3,-3,3},PlotPoints->12,ContourStyle->RGBColor[0.7,0.7,1],lightSources->{{{2,0,0},RGBColor[.5,1,0]},{{0,4,0},RGBColor[0,1,0]},{{0,4,4},RGBColor[1,1,0]},{2{0,-4,-1},RGBColor[1,0,0]},{{2,1,-2},RGBColor[0,1,1]}},ViewPoint->{-1,1,2},Background->lightblue,Boxed->False,Axes->None,ImageSize->1000]

Section 4.8   Morse's Lemma

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
r1=-1;
r2=0;
r3=1;
f[ri_,r_,α_]:={(Sqrt[ri+(r^2)]) Sin[α],(Sqrt[ri+(r^2)]) Cos[α],r}
parametricPlot3D[f[r1,r,α],{α,0,2 π},{r,-3,r1},PlotPoints->{71,51},Boxed->False,Axes->False,AspectRatio->1.4,ViewPoint->{4,-1,1},Background->lightblue,DisplayFunction->None][[1]];
parametricPlot3D[f[r1,r,α],{α,0,2 π},{r,-r1,3},PlotPoints->{71,51},Boxed->False,Axes->False,AspectRatio->1.4,ViewPoint->{4,-1,1},Background->lightblue,DisplayFunction->None][[1]];
p1=Graphics3D[{%,%%},lightSources->{{{-1,-2,0},RGBColor[0,1,1]},{{0,0,15},RGBColor[1,.5,0]},{{-1,0,1},RGBColor[0,1,0]},{2{1,-3,-3},RGBColor[1,.3,0]}}];
parametricPlot3D[f[r2,r,α],{α,0,2 π},{r,-3,r2},PlotPoints->{71,51},Boxed->False,Axes->False,AspectRatio->1.4,ViewPoint->{4,-1,1},Background->lightblue,DisplayFunction->None][[1]];
parametricPlot3D[f[r2,r,α],{α,0,2 π},{r,-r2,3},PlotPoints->{71,51},Boxed->False,Axes->False,AspectRatio->1.4,ViewPoint->{4,-1,1},Background->lightblue,DisplayFunction->None][[1]];
p2=Graphics3D[{%,%%},lightSources->{{{-1,-2,0},RGBColor[0,1,1]},{{0,0,15},RGBColor[1,.5,0]},{{-1,0,1},RGBColor[0,1,0]},{2{1,-3,-3},RGBColor[1,.3,0]}}];
parametricPlot3D[f[r3,r,α],{α,0,2 π},{r,-3,3},PlotPoints->{71,51},Boxed->False,Axes->False,AspectRatio->1.4,ViewPoint->{4,-1,1},Background->lightblue,DisplayFunction->None][[1]];
p3=Graphics3D[{%},lightSources->{{{-1,-2,0},RGBColor[0,1,1]},{{0,0,15},RGBColor[1,.5,0]},{{-1,0,1},RGBColor[0,1,0]},{2{1,-3,-3},RGBColor[1,.3,0]}}];
GraphicsGrid[{{p1,p2,p3}},ImageSize->1200,DisplayFunction->$DisplayFunction]

Morse's Lemma
Illustration

Missing. P38SB

CHAPTER 5: THEORY

Definition 5.1.1 
Illustration

Missing. P411D

Example 5.3.3 
Illustration

Missing. P423V

Example 5.3.4 
Illustration

Missing. P422V

Example 5.3.4 
New Illustration

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
sphere[{x1_,x2_,x3_}][α_,θ_]:={x1+Cos[α]Cos[θ],x2+Sin[α]Cos[θ],x3+Sin[θ]}
(* unit sphere centered at origin *) 
s1=parametricPlot3D[Evaluate[Append[sphere[{0,0,0}][α,θ],SurfaceColor[RGBColor[0.7,0.7,0]]]],{α,0,π/2},{θ,π/8,π/4.5},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},plotPoints->35,DisplayFunction->None];
(* unit sphere centered at (0,0,1) *) 
s2=parametricPlot3D[Evaluate[Append[sphere[{0,0,1}][α,θ],SurfaceColor[RGBColor[0.7,0.7,1]]]],{α,0,π/2},{θ,-π/5,-π/8},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},plotPoints->35,DisplayFunction->None];
(* point in intersection of two spheres and gradient vector for sphere s1 *)
p1=sphere[{0,0,0}][π/4,π/6];
p1==sphere[{0,0,1}][π/4,-π/6]
(* gradient vector for sphere s2 *) 
p2=sphere[{0,0,1}][π/4,-π/6]-{0,0,1};
(* cross product of p1 and p2 *) 
p3=Cross[p1,p2];
l1=Graphics3D[{Thickness[0.003],RGBColor[0,0.5,0],Line[{p1,1.3p1}]}];
(* gradient vector for sphere s2 *) 
l2=Graphics3D[{Thickness[0.003],darkblue,Line[{p1,p1+0.25p2}]}];
(* tangent line to intersection of the spheres *) 
l3=Graphics3D[{Thickness[0.003],RGBColor[1,0,0],Line[{p1-p3,p1+p3}]}];
(* intersection of two spheres *)
t=parametricPlot3D[Append[sphere[{0,0,0}][α,π/6],RGBColor[1,0,0]],{α,0,π/2},DisplayFunction->None];
Print["Geometric tangent line to the intersection of two surfaces"]
show[s1,l1,s2,l2,l3,t,BoxRatios->{1,1,1/3},ViewPoint->{-2,5,0.6},Background->lightblue,Axes->False,Boxed->False,Ticks->None,ImageSize->1200,DisplayFunction->$DisplayFunction];

Example 5.3.5 
Illustration

Point of arrow has been added by means of Xfig.

Clear["`*"]
Off[General::spell1]
lightblue=RGBColor[220/256,248/256,248/256];
x10    =0.5;
x1min=-0.3;
x1max=0.3;
x20     =0.5;
x2min =-0.3;
x2max =0.3;
tmin   =0;
tmax   =1;

f[x1_,x2_]:=(Sqrt[1-((x1^4)+(x2^4))]);
graph[x1_,x2_]:={x1,x2,f[x1,x2]};
h[x1_,x2_,x3_]:=(x1^4)+(x2^4)+(x3^2)-1;
tangentplane[f_][x10_,x20_][h1_,h2_]:=f[x10,x20]+(∂_xx1) f[xx1,xx2]h1+(∂_xx2) f[xx1,xx2]h2/.{xx1->x10,xx2->x20};
grad={4 (x1^3),4 (x2^3),2 x3}/.{x1->x10,x2->x20,x3->f[x10,x20]};
normal[t_]:=graph[x10,x20]+t grad;

g=parametricPlot3D[graph[x10+x1,x20+x2]//Evaluate,{x1,x1min,x1max},{x2,x2min,x2max},Ticks->False,Boxed->False,Axes->False,Background->lightblue,DisplayFunction->None];
tt=parametricPlot3D[tangentplane[graph][x10,x20][h1,h2]//Evaluate,{h1,x1min,x1max},{h2,x2min,x2max},Ticks->False,Boxed->False,Axes->False,ColorFunction->(Red&),DisplayFunction->None];
n=parametricPlot3D[normal[t],{t,tmin,tmax},Ticks->False,Boxed->False,Axes->False,DisplayFunction->None];
l=Graphics3D[{Thickness[0.004],RGBColor[0,0.5,0],Line[{{1.,1.,2.806243040080456},{0.5,0.5,0.9354143466934853}}]}];
show[g,tt,l,ViewPoint->{1.2,2,-0.4},ImageSize->900,DisplayFunction->$DisplayFunction];

Example 5.3.6   (Cycloid) 
Illustration

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];p1=parametricPlot[{t-Sin[t],1-Cos[t]},{t,-1.5,2 π+1.5},PlotStyle->RGBColor[1,0,0],AspectRatio->Automatic,PlotStyle->AbsoluteThickness[1.5],DisplayFunction->None];
p2=Graphics[{AbsoluteThickness[1],darkblue,Dashing[{0.0125,0.0125}],Circle[{1.5,1},1],Circle[{2 π-1.5,1},1]},DisplayFunction->None];
p3=Graphics[{AbsolutePointSize[5],Point[{1.5-Sin[1.5],1-Cos[1.5]}],Point[{2 π-1.5-Sin[2 π-1.5],1-Cos[2 π-1.5]}]},PlotRange->{0,3},DisplayFunction->None];
p4=Show[p1,p2,p3,AspectRatio->1,Ticks->{{0,π,2 π},{1}}];
R[a_]:={{Cos[a],Sin[a]},{-Sin[a],Cos[a]}}
arrow[x_,y_,h_,b_,a_]:=Polygon[{R[a].{-2 b,-4 h}+{x,y},{x,y},R[a].{2 b,-4 h}+{x,y},R[a].{0,-3 h}+{x,y}}]
show[p4,Graphics[{darkblue,arrow[π,2,0.075,0.05,0.49 π],arrow[0.7 π-Sin[0.7 π],1-Cos[0.7 π],0.075,0.05,0.325 π],arrow[1.4 π-Sin[1.4 π],1-Cos[1.4π],0.075,0.05,0.695 π]}],AxesStyle->RGBColor[0,0.5,0],AspectRatio->Automatic,Background->lightblue,ImageSize->900,PlotRange->All,DisplayFunction->$DisplayFunction];

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
ϕ[t_]:={t-Sin[t],1-Cos[t]}
ϕ'[t]
ν[t_]:=fullSimplify[Norm[ϕ'[t]],Im[t]==0]
ν[t]
Print["Graph of norm of the tangent vector"]
plot[ν[t],{t,-1.5,2π+1.5},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,Ticks->None,PlotRange->{{-1,2π+1},{-0.2,2.2}},AspectRatio->Automatic,ImageSize->900];
Print["The tangent vector itself and the normalized tangent vector, both issuing from the origin"]
τ[t_]:=(1/(ν[t])) ϕ'[t]
p1=parametricPlot[ϕ'[t],{t,0.01,2π},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,PlotRange->{{-0.1,2.2},{-1.1,1.1}},AspectRatio->1,DisplayFunction->None];
p2=parametricPlot[τ[t],{t,0.01,2π},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,PlotRange->{{-0.1,1.2},{-1.1,1.1}},AspectRatio->Automatic,DisplayFunction->None];
show[GraphicsGrid[{{p1,p2}}],Background->lightblue,ImageSize->700,DisplayFunction->$DisplayFunction];

Example 5.3.7   (Descartes' folium) 
Illustration

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
a=1;
ϕ[t_]:=((3a)/(1+(t^3))){t,(t^2)}
f1[t_]:=ϕ[t][[1]]
f2[t_]:=ϕ[t][[2]]
R[a_]:={{Cos[a],Sin[a]},{-Sin[a],Cos[a]}}
arrow[x_,y_,h_,b_,a_]:=Polygon[{R[a].{-2 b,-4 h}+{x,y},{x,y},R[a].{2 b,-4 h}+{x,y},R[a].{0,-3 h}+{x,y}}]
p1=parametricPlot[ϕ[t],{t,-0.8,1},PlotStyle->RGBColor[1,0,0],plotPoints->30,PlotStyle->{AbsoluteThickness[1]},Ticks->None,AspectRatio->Automatic,DisplayFunction->None];
p2=parametricPlot[RotateLeft[ϕ[t]],{t,-0.8,1},PlotStyle->RGBColor[1,0,0],plotPoints->30,PlotStyle->{AbsoluteThickness[1]},Ticks->None,AspectRatio->Automatic,DisplayFunction->None];
p3=Graphics[{AbsoluteThickness[0.5],Dashing[{0.025,0.025}],darkblue,Line[{{-3,2},{2,-3}}]}];
p4=Graphics[{darkblue,arrow[f1[-0.4],f2[-0.4],0.05,0.04,0.71 π],arrow[f1[2],f2[2],0.05,0.04,1.3 π],arrow[f1[-2.2],f2[-2.2],0.05,0.04,2.8 π],{AbsoluteThickness[0.5],Line[{{0,0},{-0.15,0.15}}],Line[{{0,0},{0.15,-0.15}}]},Text["-a",{-1,0},{1.5,2}],Text["-a",{0,-1},{2,1}],{AbsolutePointSize[5],Point[{0,0}],Point[{f1[-0.5],f2[-0.5]}],Point[{f1[-2],f2[-2]}],Point[{f1[1],f2[1]}]},Text["t=1",{f1[1],f2[1]},{-2,0}],Text["t=-2",ϕ[-2],{-2,-0.5}],Text["t=-.5",ϕ[-0.5],{-1.5,-0.5}],Text["t=0",{0,0},{2,-5}],Text["t=±∞",{0,0},{-3,3.5}]}];
show[p1,p2,p3,p4,PlotRange->{{-3.5,3.5},{-2.5,2}},Ticks->None,BaseStyle->Large,AxesStyle->RGBColor[0,0.5,0],Background->lightblue,DisplayFunction->$DisplayFunction,ImageSize->900];

Print["The two curves im(ϕ) and im((Overscript[ϕ, ∼])) plotted separately"]
ϕ[t_]:=((3a)/(1+(t^3))){t,(t^2)}
p5=parametricPlot[Evaluate[ϕ[t]],{t,-1/2,1},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,AspectRatio->Automatic,PlotRange->{-2,2},Ticks->None,DisplayFunction->None];
p6a=parametricPlot[Evaluate[ϕ[1/t]],{t,.001,1},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,AspectRatio->Automatic,PlotRange->{{-0.2,1.7},{-2,2}},Ticks->None,DisplayFunction->None];p6b=parametricPlot[Evaluate[ϕ[1/t]],{t,-.7,-.00},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,AspectRatio->Automatic,PlotRange->{{-0.2,1.7},{-2,2}},Ticks->None,DisplayFunction->None];
p6=Show[p6a,p6b];
show[GraphicsGrid[{{p5,p6}}],Background->lightblue,ImageSize->900,DisplayFunction->$DisplayFunction];

Print["Descartes' folium with vectors (uniformly) proportional to the gradient vectors"]
Off[General::spell1]
g[x1_,x2_]:=(x1^3)+(x2^3)-3a x1 x2
gradg[{x1_,x2_}]:={(∂_xx1) g[xx1,xx2],(∂_xx2) g[xx1,xx2]}/.{xx1->x1,xx2->x2}
grad[t_]:=0.1Simplify[Composition[gradg,ϕ][t]]
normal[t_]:={darkblue,Line[{ϕ[t],ϕ[t]+grad[t]}]}
grads1=Graphics[Evaluate[Table[normal[t],{t,-1/2,1,0.005}]],DisplayFunction->None];
curve1=parametricPlot[Evaluate[ϕ[t]],{t,-1/2,1},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,AspectRatio->Automatic,PlotRange->{-2,2},Ticks->None,DisplayFunction->None];
p7=show[curve1,grads1,AspectRatio->Automatic,Axes->None,PlotRange->All,DisplayFunction->None];
grads2=Graphics[Evaluate[Table[normal[1/t],{t,-1/2,1,0.0051}]],DisplayFunction->None];
curve2=parametricPlot[Evaluate[ϕ[1/t]],{t,-1/2,1},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,AspectRatio->Automatic,PlotRange->{-2,2},Ticks->None,DisplayFunction->None];
p8=show[curve2,grads2,AspectRatio->Automatic,Axes->None,PlotRange->All,DisplayFunction->None];
show[p7,p8,ImageSize->900,DisplayFunction->$DisplayFunction];
Print["Level curves of function g"]
a=1;
p9=contourPlot[g[x1,x2],{x1,-4,4},{x2,-4,4}, Contours->251,plotPoints->300, ColorFunction->Hue,Ticks->None, Frame->False,DisplayFunction->None];
show[p9,ImageSize->915,DisplayFunction->$DisplayFunction];
Print["Restriction of function g to bisectrix of plane"]
plot[g[t,t],{t,-0.5,1.7},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,AspectRatio->Automatic,ImageSize->400];

Example 5.3.8   (Cusp of a plane curve) 
New Illustration

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
γ[t_]:={(t^2),(t^3)}
Print["Semicubic parabola"]
parametricPlot[γ[t],{t,-1,1},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,AspectRatio->Automatic,PlotRange->{{-0.1,1.1},{-1.1,1.1}},ImageSize->300,Ticks->None];
Eliminate[{(Subscript[x, 1]),(Subscript[x, 2])}==γ[t],t]
γ'[t]
Solve[γ'[t]=={0,0},t][[1]]/.{Rule->Equal}
ν[t_]:=fullSimplify[Norm[γ'[t]],Im[t]==0]
ν[t]
Print["Normalized tangent vector"]
T[t_]:=(1/(ν[t])) γ'[t]
p1=parametricPlot[T[t],{t,-1,0},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,PlotRange->{{-1,0},{0,1}},AspectRatio->Automatic,ImageSize->300,DisplayFunction->None];
p2=Graphics[{darkblue,AbsolutePointSize[5],Point[T[-1]]},DisplayFunction->None];
p3=Show[p1,p2];
p4=parametricPlot[T[t],{t,0.01,1},PlotRange->{{0,1},{0,1}},AspectRatio->Automatic,ImageSize->300,DisplayFunction->None];
p5=Graphics[{darkblue,AbsolutePointSize[5],Point[T[1]]},DisplayFunction->None];
p6=Show[p4,p5];
show[GraphicsGrid[{{p3,p6}}],Background->lightblue,ImageSize->800,DisplayFunction->$DisplayFunction];
γ''[0]
γ'''[0]
Print["Higher-order cusp; note its flatness"]
δ[t_]:={(t^2),(t^7)}
parametricPlot[δ[t],{t,-1,1},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,AspectRatio->Automatic,PlotRange->{{-0.1,1.1},{-1.1,1.1}},ImageSize->300,Ticks->None];

Descartes' folium with vectors (uniformly) proportional to the gradient vectors (This text is misplaced ?)

Section 5.7   Gaussian curvature of surface

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
f[t_]:=5 Sin[t/4]+4
plot[f[t],{t,0,3 π},PlotStyle->RGBColor[1,0,0],PlotRange->{{-2,11},{-2,11}},AspectRatio->1,DisplayFunction->None];
Graphics[{darkblue,Line[{{2π,f[2π]},{2π,f[2π]+2}}],Line[{{0,f[0]},{-10/Sqrt[41],8+8/Sqrt[41]-f[0]}}],Line[{{3 π,f[3 π]},{3 π+10/Sqrt[57],f[3 π]+8 Sqrt[2/57]}}]}];
Graphics[{darkblue,Line[{{π,0},{3 π,0}}],Line[{{2 π,0},{2 π,2}}],Line[{{2 π,0},{2 π-10/Sqrt[41],8/Sqrt[41]}}],Line[{{2π,0},{2π+10/Sqrt[57],8 Sqrt[2/57]}}],{RGBColor[1,0,0],Circle[{2 π,0},2,{0.27 π,0.785 π}]}}];
Graphics[{Text["x",{2π,f[2π]},{0,3}],Text["V",{1.5,5}],Text["0",{2 π,0},{0,2}],Text["n(x)",{6.5,2.5}],Text["S2",{2 π-1.5,1.75}],Text["T",{2 π+2,0},{-1,-3}]}];
show[%%%%,%%%,%%,%,Axes->None,Background->lightblue,defaultFont->12.,ImageSize->500,DisplayFunction->$DisplayFunction];

Section 5.11   Transversality

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
f[x_]:=0.2 (x^2)
g[n_,x_]:=-((f[x])/n)
a=0.7;
h[x_]:=2 (Sqrt[x])

plot[-f[x],{x,-1,1},plotPoints->100,DisplayFunction->None];
plot[{2 Sqrt[x],-2 Sqrt[x]},{x,0,0.6},plotPoints->100,DisplayFunction->None];
fig1=show[%%,%,Graphics[Text["a",{-0.1,-.7}]],BaseStyle->Large,BaseStyle->darkblue,AspectRatio->1,Axes->False,PlotRange->{{-1.5,1.5},Automatic},Background->lightblue,DisplayFunction->$DisplayFunction];

plot[{f[x+0.5],-f[x+0.5]},{x,-2,-0.5},plotPoints->100,DisplayFunction->None];
plot[0,{x,-0.5,0.5},plotPoints->100,DisplayFunction->None];
plot[{f[x-0.5],-f[x-0.5]},{x,0.5,2},plotPoints->100,DisplayFunction->None];
fig2=show[%%%,%%,%,Graphics[Text["b",{0,-0.01}]],BaseStyle->Large,BaseStyle->darkblue,Axes->False,PlotRange->{{-1.5,1.5},Automatic},Background->lightblue,DisplayFunction->$DisplayFunction];

plot[{f[x],-f[x]},{x,-1,1},Axes->False,PlotRange->{{-1.5,1.5},Automatic},plotPoints->100,AspectRatio->0.7,Background->lightblue,DisplayFunction->None];
fig3=show[%,Graphics[Text["c",{0,-0.1}]],BaseStyle->{Large},Background->lightblue,DisplayFunction->$DisplayFunction];

plot[g[3,x]+a,{x,-2.5,2.5},plotPoints->100,DisplayFunction->None];
plot[g[3,x]-a,{x,-2,2},plotPoints->100,DisplayFunction->None];
Graphics[{Line[{{-2.5,g[3,-2.5]+a},{-2,g[3,-2]-a}}],Line[{{2.5,g[3,2.5]+a},{2,g[3,2]-a}}],{AbsolutePointSize[4],Point[{0,0}]}}];
plot[2 (Sqrt[x]),{x,0,0.5},plotPoints->100,DisplayFunction->None];
plot[-2 (Sqrt[x]),{x,0,0.122852},PlotStyle->Dashing[{0.01,0.01}],plotPoints->100,DisplayFunction->None];
plot[-2 (Sqrt[x]),{x,0.122852,0.5},plotPoints->100,DisplayFunction->None];
fig4=show[%%%%%%,%%%%%,%%%%,%%%,%%,%,Graphics[Text["d",{-0.1,-1.2}]],BaseStyle->{Large},AspectRatio->1,PlotRange->{{-3,3},Automatic},Axes->False,Background->lightblue,DisplayFunction->$DisplayFunction];

plot[g[3,x]+a,{x,-2.5,2.5},plotPoints->100,DisplayFunction->None];
plot[g[3,x]-a,{x,-2,2},plotPoints->100,DisplayFunction->None];
Graphics[{Line[{{-2.5,g[3,-2.5]+a},{-2,g[3,-2]-a}}],Line[{{2.5,g[3,2.5]+a},{2,g[3,2]-a}}],{AbsolutePointSize[4],Point[{0,0}]}}];
plot[2 f[x+0.5],{x,-2.5,-0.5},plotPoints->100,DisplayFunction->None];
plot[0,{x,-0.5,0.5},plotPoints->100,DisplayFunction->None];
plot[-4 f[x-0.5],{x,0.5,1.53507},PlotStyle->{Dashing[{0.01,0.01}]},plotPoints->100,DisplayFunction->None];
plot[-4 f[x-0.5],{x,1.53507,2.25},plotPoints->100,DisplayFunction->None];
fig5=show[%%%%%%%,%%%%%%,%%%%%,%%%%,%%%,%%,%,Graphics[Text["e",{0,-1.5}]],BaseStyle->Large,BaseStyle->{darkblue,Large},AspectRatio->Automatic,PlotRange->{{-3,3},Automatic},Axes->False,Background->lightblue,DisplayFunction->$DisplayFunction];

plot[g[3,x]+a,{x,-2.5,2.5},DisplayFunction->None];
plot[g[3,x]-a,{x,-2,2},DisplayFunction->None];
Graphics[{Line[{{-2.5,g[3,-2.5]+a},{-2,g[3,-2]-a}}],Line[{{2.5,g[3,2.5]+a},{2,g[3,2]-a}}],{AbsolutePointSize[4],Point[{0,0}]}}];
plot[1.2 (x^2),{x,-1,1},plotPoints->100,Background->lightblue,DisplayFunction->None];
fig6=show[%%%%,%%%,%%,%,Graphics[Text["f",{0,-1.5}]],BaseStyle->Large,BaseStyle->{darkblue,Large},AspectRatio->1,Axes->False,PlotRange->{3,-3},Background->lightblue,DisplayFunction->$DisplayFunction];

GraphicsGrid[{{fig1,fig2,fig3},{fig4,fig5,fig6}},BaseStyle->Large,ImageSize->360]

b=0.85;
b1=0.5;
b2=0.65;
a=0.5;
plot[g[3,x]+a,{x,-2.5,-0.440695},DisplayFunction->None];
plot[g[3,x]+a,{x,-0.440695,0.310899},PlotStyle->{Dashing[{0.01,0.01}]},DisplayFunction->None];
plot[g[3,x]+a,{x,0.310899,2.5},DisplayFunction->None];
plot[g[3,x]-a,{x,-2,2},DisplayFunction->None];
plot[h[x+0.5],{x,-0.5,-0.440695},PlotStyle->{Dashing[{0.01,0.01}]},plotPoints->100,DisplayFunction->None];
plot[h[x+0.5],{x,-0.440695,0.1},plotPoints->100,DisplayFunction->None];
plot[-h[x+0.5],{x,-0.5,-0.440695},PlotStyle->{Dashing[{0.01,0.01}]},plotPoints->100,DisplayFunction->None];
plot[-h[x+0.5],{x,-0.440695,0.1},plotPoints->100,DisplayFunction->None];
plot[{h[x-0.25],-h[x-0.25]},{x,0.25,0.8},plotPoints->100,DisplayFunction->None];
Graphics[{Line[{{-2.5,g[3,-2.5]+a},{-2,g[3,-2]-a}}],Line[{{2.5,g[3,2.5]+a},{2,g[3,2]-a}}],Line[{{0.1,h[0.6]},{0.8,h[0.55]}}],Line[{{0.1,-h[0.6]},{0.8,-h[0.55]}}],Line[{{-0.440695,h[-0.440695+0.5]},{0.314156,-h[0.314156-0.25]}}]}];
show[%%%%%%%%%%,%%%%%%%%%,%%%%%%%%,%%%%%%%,%%%%%%,%%%%%,%%%%,%%%,%%,%,Graphics[Text["a",{-0.2,-1.4}]],BaseStyle->{Large},Axes->None,AspectRatio->Automatic,PlotRange->{{-3,3},Automatic},Background->lightblue,DisplayFunction->$DisplayFunction];

a=0.5;
plot[g[3,x]+a,{x,-2.5,-2.01165},DisplayFunction->None];
plot[g[3,x]+a,{x,-2.01165,1.62204},PlotStyle->{Dashing[{0.01,0.01}]},DisplayFunction->None];
plot[g[3,x]+a,{x,1.62204,2.5},DisplayFunction->None];
plot[g[3,x]-a,{x,-2,2},DisplayFunction->None];
plot[-g[b,x+0.25]-a,{x,-2.5,2.5},DisplayFunction->None];
plot[-g[b2,x]+a,{x,-2,0},DisplayFunction->None];
plot[-g[b1,x]+a,{x,0,2},DisplayFunction->None];
Graphics[{Line[{{-2.5,g[3,-2.5]+a},{-2,g[3,-2]-a}}],Line[{{2.5,g[3,2.5]+a},{2,g[3,2]-a}}],Line[{{-2.5,-g[b,-2.25]-a},{-2,-g[b2,-2]+a}}],Line[{{2.5,-g[b,2.75]-a},{2,-g[b1,2]+a}}],Line[{{0,a},{-0.25,-g[b,0]-a}}]}];
show[%%%%%%%%,%%%%%%%,%%%%%%,%%%%%,%%%%,%%%,%%,%,Graphics[Text["d",{0,-1.4}]],BaseStyle->{Large},Axes->None,AspectRatio->Automatic,PlotRange->{-2,2.2},Background->lightblue,DisplayFunction->$DisplayFunction];

a=0.5;
Clear[r];
Clear[s];
r[t_]:=1
s[t_]:=0.2
plot[g[3,x]+a,{x,-2.5,-0.628281},DisplayFunction->None];
plot[g[3,x]+a,{x,0.628281,2.5},DisplayFunction->None];
plot[g[3,x]-a,{x,-2,2},DisplayFunction->None];
Graphics[{Line[{{-2.5,g[3,-2.5]+a},{-2,g[3,-2]-a}}],Line[{{2.5,g[3,2.5]+a},{2,g[3,2]-a}}],{AbsolutePointSize[4],Point[{0,0}]}}];
plot[1.2 x^2,{x,-1,1},plotPoints->100,DisplayFunction->None];
parametricPlot[{r[t] Cos[t],s[t] Sin[t]+1.2},{t,0,2 π},plotPoints->100,DisplayFunction->None];
show[%%%%%%,%%%%%,%%%%,%%%,%%,%,Graphics[Text["c",{0,-1.5}]],BaseStyle->{Large},AspectRatio->Automatic,PlotRange->{-2,2},Axes->False,Background->lightblue,BaseStyle->Large,DisplayFunction->$DisplayFunction];

CHAPTER 0: EXERCISES

Exercise 0.1   (Rational parametrization of circle)

Mathematica needs some assistance in the exercise.

Clear["`*"]
Off[Solve::ifun]
tt=((Sin[α])/(1+Cos[α]))
Simplify[tt==((1-Cos[α])/(Sin[α]))]
Solve[t==((1-Cos[α])/(Sin[α])),Cos[α]]
sol=Flatten[Solve[{t==((1-Cos[αα])/(Sin[αα])),Cos[αα]==(Sqrt[1-Sin[αα]^2])},αα]] 
α=αα/.sol[[2]]
Cos[α]
Simplify[Sin[α],t>0]

Clear[α,t]
α=ArcTan[t];
((Cos[α])^2)
((Sin[α])^2)

Exercise 0.3

Mathematica does not produce  the desired formula directly.

Clear["`*"]
fullSimplify[ArcTan[(1/x)]+ArcTan[x],x>0]
Simplify[(∂_x)%]
%%/.x->1
%%%/.x->-1
Limit[x((π/2)-ArcTan[x]),x->∞]

Exercise 0.6

Clear["`*"]
f[x_]:=(1/(Sqrt[(x-a)(b-x)]))
fullSimplify[∫f[x]\[DifferentialD]x,{a<x<b}]
fullSimplify[∫f[x]\[DifferentialD]x==-2ArcTan[(Sqrt[((b-x)/(x-a))])],{Im[a]==0,Im[b]==0,a<x<b}]
Simplify[(∂_x) ArcSin[((2x-b-a)/(b-a))],{a<x<b}]
Simplify[Together[(∂_x) ArcCos[((b+a-2x)/(b-a))]],{a<x<b,b-a>0}]
PowerExpand[Simplify[-2(∂_x)ArcTan[(Sqrt[((b-x)/(x-a))])],{a<x<b,b-a>0}]]
Integrate[f[x],{x,a,b},Assumptions->{a<x<b}]

Exercise 0.7

Mathematica is unable to directly verify all desired identities.

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
i[α_]=fullSimplify[Integrate[(1/(Cos[α])),α],Sin[α]==2((Cos[(α/2)])^2)-1]
j[α_]=(1/2)Log[((1+Sin[α])/(1-Sin[α]))]
fullSimplify[i[α]-j[α],{Sin[α]==2Sin[(α/2)]Cos[(α/2)],0<α<(π/2)}]
Simplify[(∂_α)j[α]]
i[0]-j[0]
plot[i[α]-j[α],{α,0,(π/2)-.01},PlotStyle->RGBColor[1,0,0],PlotRange->All,AxesStyle->RGBColor[0,0.5,0],Background->lightblue,ImageSize->600];
k[α_]=Log[Tan[(α/2)+(π/4)]]
PowerExpand[fullSimplify[i[α]-k[α],{Cos[α]==1-2((Sin[(α/2)])^2),0<α<(π/2)}]]
α=π/3.5;
p[t_]:={Cos[t],Sin[t]}
pl[1]=parametricPlot[p[t],{t,-π,π},PlotStyle->darkblue,DisplayFunction->None];
pl[2]=parametricPlot[0.2p[t],{t,0,α},PlotStyle->RGBColor[1,0,0],DisplayFunction->None]; 
pl[3]=Graphics[{darkblue,PointSize[0.015],Point[0p[0]],Point[p[π/2]],Point[p[α]],Point[{Tan[α/2+π/4],0}]}];
pl[4]=Graphics[{darkblue,Line[{p[α],0p[0],p[π/2],{Tan[α/2+π/4],0},0p[0]}]}];
show[Table[pl[j],{j,4}],Axes->False,Ticks->None,AspectRatio->Automatic,Background->lightblue,ImageSize->600,PlotRange->All,DisplayFunction->$DisplayFunction];

Exercise 0.8

Clear["`*"]
Off[General::spell1]
ComplexExpand[Integrate[(E^((-p+I q)x)),{x,0,∞},Assumptions->{p>0,Im[q]==0}]]
Integrate[(E^(-p x))Cos[q x],{x,0,∞},Assumptions->{p>0,Im[q]==0}]
Integrate[(E^(-p x))Sin[q x],{x,0,∞},Assumptions->{p>0,Im[q]==0}]

Exercise 0.13  (Partial-fraction decomposition of trigonometric functions, and Wallis' product)

Clear["`*"]
Print["Part (i)"]
8x (∑_(k=1)^∞)(1/((((2k-1))^2)-4(x^2)))
Simplify[-Tan[π(x+(1/2))]]
Simplify[(1/x)+2x (∑_(k=1)^∞)(1/((x^2)-(k^2)))]
Simplify[π Cot[π(( x)/2)]-π Cot[π((x+1)/2)]]
Simplify[(1/x)+2x (∑_(k=1)^∞)((((-1))^k)/((x^2)-(k^2)))]
Simplify[2 (∑_(k=1)^∞)(((-1))^k)((2k-1)/((x^2)-(((2k-1))^2)))]
Print["Part (ii)"]
fullSimplify[Integrate[π Cot[π x]-(1/x),x]]
Simplify[π x (∏_(k=1)^∞)(1-((x^2)/(k^2))),x>0]
Print["Part (iii)"]
(∏_(n=1)^∞)(1-(1/(4(n^2))))
Limit[(((((2^n) n!))^2)/((2n)!(Sqrt[2n+1]))),n->∞]
Print["Part (iv)"]
f[x_]:=(π/ω) Cot[((π x)/ω)]
Simplify[f'[x]==-((f[x])^2)-6(∑_(k=1)^∞)(1/(((k ω))^2))]

Exercise 0.14    ((∫_(SubPlus[ℝ]))((sin x)/x)dx = (π/2))

Clear["`*"]
(∑_(k=-∞)^∞)(((Sin[x+k π])^2)/(((x+k π))^2))
Integrate[(((Sin[x])^2)/(x^2)),{x,-∞,∞}]
Integrate[((Sin[x])/x),{x,0,∞}]

Exercise 0.15   (Special values of Beta function)

Clear["`*"]
Print["Part (i)"]
Simplify[(∑_(k=0)^∞)(((-1))^k) (x^(p+k-1)),{0<x<1}]
Print["Part (ii)"]
Simplify[Integrate[((x^(p-1))/(x+1)),{x,0,1},Assumptions->{0<p<1}]==(∑_(k=0)^∞)((((-1))^k)/(p+k))]
Print["Part (iii)"]
FullSimplify[Integrate[((x^(p-1))/(x+1)),{x,1,∞},Assumptions->{0<p<1}]==(∑_(k=1)^∞)((((-1))^k)/(p-k))]
Print["Part (iv)"]
Integrate[((x^(p-1))/(x+1)),{x,0,∞},Assumptions->{0<p<1}]
Print["Part (v)"]
Integrate[(((x^(p-1))Log[x])/(x-1)),{x,0,∞},Assumptions->{0<p<1}]

Exercise 0.16   (Bernoulli polynomials, Bernoulli numbers, and power series expansion for tangent)

Apparently Mathematica does neither recognize the generating function relation for the Bernoulli polynomials nor the Bernoulli summation formula. 
For no good reason Mathematica adds asymptotes to the illustration, which we have had to remove by hand.

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
Print["Part (iii)"]
Table[BernoulliB[n,x],{n,0,5}]
Factor[%[[4]]]
Factor[%%[[6]]]
fullSimplify[(∑_(n=0)^∞)((BernoulliB[n,x](t^n))/(n!))==((t (E^(x t)))/((E^t)-1)),t>0]
Print["Part (v)"]
fullSimplify[1==((∑_(n=1)^∞)((t^(n-1))/(n!)))((∑_(n=0)^∞)((BernoulliB[n](t^n))/(n!))),t>0]
Print["Part (viii)"]
Simplify[(t/((E^t)-1))+(t/2)==1+(∑_(n=2)^∞)((BernoulliB[n](t^n))/(n!)),t>0]
Print["Part (ix)"]
Table[BernoulliB[2n],{n,1,6}]
Print["Part (xi)"]
fullSimplify[(p+1)(∑_(k=1)^n)(k^p)==(n^p)+(n^(p+1))(∑_(k=0)^p)((Binomial[p+1,k]BernoulliB[k])/(n^k)),{Element[p ,Integers],p>0}]
Print["Part (xiii)"]
fullSimplify[(∑_(n=1)^∞)(((((-1))^(n-1))(2^(2n))((2^(2n))-1)BernoulliB[2n](x^(2n-1)))/((2n)!))==Tan[x],{-(π/2)<x<(π/2)}]
Series[Tan[x],{x,0,19}]

p1=plot[Evaluate[Normal[Series[Tan[x],{x,0,19}]]],{x,-3π/4,3π/4},PlotRange->{-58,58},PlotStyle->darkblue,Background->lightblue,ImageSize->900,Ticks->{{-π/2,π/2},{-40,-20,20,40}},DisplayFunction->None];
plot[Evaluate[Tan[x]],{x,-3π/4,3π/4},PlotStyle->RGBColor[1,0,0],Background->lightblue,PlotRange->{-58,58},ImageSize->900,Ticks->{{-π/2,π/2},{-40,-20,20,40}},DisplayFunction->None];
p2=show[%//.Line[{a___,b:{_,y1_},c:{_,y2_},d___}]:>Sequence[Line[{a,b}],Line[{c,d}]]/;Abs[y1-y2]>20,PlotRange->{-58,58},DisplayFunction->None];
show[p1,p2,AxesStyle->RGBColor[0,0.5,0],ImageSize->1100,DisplayFunction->$DisplayFunction];

Exercise 0.18

In this exercise it is necessary to use the functions Re, Im and Arg as introduced in Example 3.1.1 above. In the illustration Mathematica plots vertical lines without due cause; therefore these are removed by hand.

Clear["`*"]
Off[General::spell1]
re[z_]:=(1/2)(z+Conjugate[z])
im[z_]:=(1/(2I))(z-Conjugate[z])
arg[z_]:=2ArcTan[((im[z])/((Sqrt[((re[z])^2)+((im[z])^2)])+re[z]))]

f[z_]:=-Log[1-z]
Integrate[(∑_(k=0)^∞)(z^k),z]==f[z]
(∑_(k=1)^∞)((z^k)/k)==f[z]
fullSimplify[(∑_(k=1)^∞)((Cos[k α])/k)==re[f[(E^(I α))]],{0<α<2π}]
fullSimplify[re[f[(E^(I α))]]==-Log[2Sin[(α/2)]],0<α<2π]

The sum of cosines is obviously real. Let us check the imaginary part anyway.

claim=fullSimplify[im[(∑_(k=1)^∞)((Cos[k α])/k)]==im[-Log[2Sin[(α/2)]]],0<α<2π]
fullSimplify[claim/.Arg->arg,0<α<2π]

Now we verify that the sum of sines is a sawtooth function.

Off[General::spell]
lightblue=RGBColor[220/256,248/256,248/256];
sum=(∑_(k=1)^∞)((Sin[k α])/k)
fullSimplify[ComplexExpand[sum]/.Arg->arg,0<α<2π]
plot[Evaluate[sum],{α,-2π,4π},AspectRatio->Automatic,PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,ImageSize->1200,Ticks->{{-2π,-π,π,2π,3π,4π},{-π/2,π/2}},DisplayFunction->None];
show[%//.Line[{a___,b:{_,y1_},c:{_,y2_},d___}]:>Sequence[Line[{a,b}],Line[{c,d}]]/;Abs[y1-y2]>1,PlotRange->{-1.75,1.75},DisplayFunction->$DisplayFunction];
Limit[sum,α->0,Direction->-1]
Limit[sum,α->2π ,Direction->1]
fullSimplify[Tan[sum],0<α<2π]
saw=1/2(π-α)
fullSimplify[Tan[sum]==Tan[saw],0<α<2π]

The conclusion sum = saw now follows from the fact that both functions sum and saw take values in the interval  ] -(π/2),(π/2) [ , on which one may invert the tangent by means of the arctangent.

Simplify[ArcTan[Tan[α]],-(π/2)<α<(π/2)]
Simplify[-(π/2)<saw<(π/2),0<α<2π]
Simplify[ArcTan[Tan[saw]]==saw,0<α<2π]

CHAPTER 1: EXERCISES

Exercise 1.15

See the file Ex1.15.pdf

Exercise 1.45

Clear["`*"]
Off[General::spell1]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
Print["Definition of (Subscript[β, i])"]
p=Table[Graphics[{darkblue,PointSize[0.015],Point[{i,j}]}],{i,0,1,(1/2)},{j,0,1,(1/2)}];
{γγ[0],γγ[1],γγ[2],γγ[3],γγ[4],γγ[5]}=(1/3){{0,0},{1,0},{1,2},{2,2},{2,0},{3,0}};
R[0][{x1_,x2_}]:={x1,x2}-{x1,x2}.{-1,1}{-1,1}
R[1][{x1_,x2_}]:={x1,x2}
R[2]=R[1];
R[3][{x1_,x2_}]:={x1,x2}-{x1,x2}.{1,1}{1,1}+(1/2){1,1}
T[0][{x1_,x2_}]:={x1,x2}
T[1][{x1_,x2_}]:={x1,x2}+(1/2){0,1}
T[2][{x1_,x2_}]:={x1,x2}+(1/2){1,1}
T[3][{x1_,x2_}]:={x1,x2}+(1/2){1,0}
β[i_][{x1_,x2_}]:=Composition[T[i],R[i]][(1/2){x1,x2}]
gamma=Table[γγ[j],{j,0,5}];
γ=ListPlot[gamma,Joined->True,Ticks->None,Axes->False,PlotStyle->RGBColor[1,0,0],DisplayFunction->Identity]; 
gam[i_]:=Table[β[i][γγ[j]],{j,0,5}]
beta[i_]:=ListPlot[gam[i],Joined->True,Ticks->None,Axes->False,PlotStyle->RGBColor[1,0,0],DisplayFunction->Identity];

show[p,γ,AspectRatio->Automatic,Background->lightblue]; 
show[p,Table[beta[i],{i,0,3}],AspectRatio->Automatic,Background->lightblue];

Print["Definition of Φ"]
Clear[γ,gamma]
p=Table[Graphics[{darkblue,PointSize[0.015],Point[{i,j}]}],{i,0,1,(1/2)},{j,0,1,(1/2)}];
γ[t_]:={0,0}/;t<0;
γ[t_]:={t(5/3),0}/;0≤t<(1/5);
γ[t_]:={(1/3),(10/3)(t-(1/5))}/;(1/5)≤t<(2/5);
γ[t_]:={(1/3)+(5/3)(t-(2/5)),(2/3)}/;(2/5)≤t<(3/5);
γ[t_]:={(2/3),(2/3)-(10/3)(t-(3/5))}/;(3/5)≤t<(4/5);
γ[t_]:={(2/3)+(5/3)(t-(4/5)),0}/;(4/5)≤t≤1;
γ[t_]:={1,0}/;t>1;
gamma[0]=parametricPlot[γ[t],{t,0,1},Ticks->None,Axes->False,AspectRatio->Automatic,PlotStyle->RGBColor[1,0,0],Background->lightblue,DisplayFunction->None];

show[gamma[0],p,DisplayFunction->$DisplayFunction];

Φ[γ_][t_]:=(1/2){γ[4t][[2]],γ[4t][[1]]}/;0≤t<(1/4);
Φ[γ_][t_]:=(1/2){γ[4t-1][[1]],1+γ[4t-1][[2]]}/;(1/4)≤t<(2/4);
Φ[γ_][t_]:=(1/2){1+γ[4t-2][[1]],1+γ[4t-2][[2]]}/;(2/4)≤t<(3/4);
Φ[γ_][t_]:=(1/2){2-γ[4t-3][[2]],1-γ[4t-3][[1]]}/;(3/4)≤t≤1;
gamma[i_]:=parametricPlot[Nest[Φ,γ,i][t],{t,0,1},Ticks->None,Axes->False,AspectRatio->Automatic,PlotPoints->(1201i),PlotStyle->RGBColor[1,0,0],Background->lightblue,DisplayFunction->None];
Table[show[gamma[i],p,ImageSize->(400+100 i),AspectRatio->Automatic,DisplayFunction->$DisplayFunction],{i,2,4,1}] ;
gamma[6]=parametricPlot[Evaluate[Nest[Φ,γ,6][t]],{t,0,1},Ticks->None,Axes->False,AspectRatio->Automatic,PlotPoints->8000,PlotStyle->RGBColor[1,0,0],Background->lightblue,DisplayFunction->None];

show[gamma[6],p,ImageSize->800,DisplayFunction->$DisplayFunction];

(* Computing these final two pictures took 12 hours on my computer. The results are displayed.   
gamma[7]=parametricPlot[Evaluate[Nest[Φ,γ,7][t]],{t,0,1},Ticks->None,Axes->False,AspectRatio->Automatic,plotPoints->39999,PlotStyle->RGBColor[1,0,0],Background->lightblue,DisplayFunction->None];
show[gamma[7],ImageSize->800,DisplayFunction->$DisplayFunction]; 
gamma[8]=parametricPlot[Evaluate[Nest[Φ,γ,8][t]],{t,0,1},Ticks->None,Axes->False,AspectRatio->Automatic,plotPoints->99999,PlotStyle->RGBColor[1,0,0],Background->lightblue,DisplayFunction->None];
show[gamma[8],ImageSize->800,DisplayFunction->$DisplayFunction]; *)

Here is a variation where all the approximating curves have no self-intersection.

Clear["`*"]
Off[General::spell1]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
p=Table[Graphics[{darkblue,PointSize[0.005],Point[{i,j}]}],{i,0,1,(1/2)},{j,0,1,(1/2)}];
γ[t_]:={0,0}/;t<0;
γ[t_]:={(1/4),(1/4)+(6/4)t}/;0≤t<(1/3);
γ[t_]:={(1/4)+(6/4)(t-(1/3)),(3/4)}/;(1/3)≤t<(2/3);
γ[t_]:={(3/4),(3/4)-(6/4)(t-(2/3))}/;(2/3)≤t<1;
γ[t_]:={1,0}/;t>1;
Φ[γ_][t_]:=(1/2){γ[4t][[2]],γ[4t][[1]]}/;0≤t<(1/4);
Φ[γ_][t_]:=(1/2){γ[4t-1][[1]],1+γ[4t-1][[2]]}/;(1/4)≤t<(2/4);
Φ[γ_][t_]:=(1/2){1+γ[4t-2][[1]],1+γ[4t-2][[2]]}/;(2/4)≤t<(3/4);
Φ[γ_][t_]:=(1/2){2-γ[4t-3][[2]],1-γ[4t-3][[1]]}/;(3/4)≤t≤1;

gamma[n_]:=parametricPlot[Evaluate[Nest[Φ,γ,n][t]],{t,0,1},Ticks->None,Axes->False,AspectRatio->Automatic,PlotPoints->(1201 (n+1)),PlotStyle->RGBColor[1,0,0],Background->lightblue,DisplayFunction->None];
Table[show[gamma[n],p,ImageSize->800,DisplayFunction->$DisplayFunction],{n,0,4}];
(* gamma[5]:=parametricPlot[Evaluate[Nest[Φ,γ,5][t]],{t,0,1},Ticks->None,Axes->False,AspectRatio->Automatic,PlotPoints->23999,PlotStyle->RGBColor[1,0,0],Background->lightblue,DisplayFunction->None]; *)
show[gamma[5],p,ImageSize->800,DisplayFunction->$DisplayFunction];
(* gamma[6]=parametricPlot[Evaluate[Nest[Φ,γ,6][t]],{t,0,1},Ticks->None,Axes->False,AspectRatio->Automatic,PlotPoints->59999,PlotStyle->RGBColor[1,0,0],Background->lightblue,DisplayFunction->None]; *)
show[gamma[6],p,ImageSize->800,DisplayFunction->$DisplayFunction];

(* Computing the final two pictures took a substantial amount of time on my computer. The results are displayed. 
gamma[7]=parametricPlot[Evaluate[Nest[Φ,γ,7][t]],{t,0,1},Ticks->None,Axes->False,AspectRatio->Automatic,plotPoints->99999,PlotStyle->RGBColor[1,0,0],Background->lightblue,DisplayFunction->None];
show[gamma[7],ImageSize->800,DisplayFunction->$DisplayFunction]; 
gamma[8]=parametricPlot[Evaluate[Nest[Φ,γ,8][t]],{t,0,1},Ticks->None,Axes->False,AspectRatio->Automatic,plotPoints->119999,PlotStyle->RGBColor[1,0,0],Background->lightblue,DisplayFunction->None];
show[gamma[8],ImageSize->800,DisplayFunction->$DisplayFunction]; *)

Exercise 1.46

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
p[1][t_]:=0
p[k_][t_]:=(1/2)((t^2)+2p[k-1][t]-((p[k-1][t])^2))
Print["Part (i)"]
Do[Print[Simplify[Expand[p[k][t]]]],{k,10}]
Table[p[k][0],{k,10}]
Print["Part (ii)"]
Table[Simplify[Expand[2(Abs[t]-p[k+1][t])-Abs[t](2-Abs[t])+p[k][t](2-p[k][t])],Im[t]==0],{k,10}]
Table[Simplify[Expand[2(p[k+1][t]-p[k][t])-(t^2)+((p[k][t])^2)]],{k,10}]
Print["Part (iii)"]
q[k_]:=plot[p[k][t],{t,-1,1},AspectRatio->Automatic,PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,Ticks->None,plotPoints->1000,DisplayFunction->None];
a=plot[Abs[t],{t,-1,1},AspectRatio->Automatic,PlotStyle->darkblue,AxesStyle->RGBColor[0,0.5,0],Background->lightblue,Ticks->None,plotPoints->1000,DisplayFunction->None];
t[k_]:=show[a,q[k],DisplayFunction->$DisplayFunction,ImageSize->500];
Table[t[k],{k,2,10}];

CHAPTER 2: EXERCISES

Exercise 2.7

See the file Ex2.7.pdf

Exercise 2.10

Clear["`*"]
Off[General::spell1]
rmin=0.005;
rmax=1;
αmin=0;
αmax=2π;
nr=89;
nα=155;
lightblue=RGBColor[220/256,248/256,248/256];
f[x1_,x2_]:=((x1 (x2^3))/((x1^2)+(x2^4)))
x1[r_,α_]:=r Cos[α]
x2[r_,α_]:=r Sin[α]
x3[r_,α_]:=f[x1[r,α],x2[r,α]]
parametricPlot3D[{x1[r,α],x2[r,α],x3[r,α]}//Evaluate,{r,rmin,rmax},{α,αmin,αmax},plotPoints->{nr,nα},ViewPoint->{1,1,1},Boxed->False,Axes->False,Ticks->None,PlotRange->{{-1,1},{-1,1},{-0.45,0.45}},Background->lightblue,ImageSize->1200];
Limit[((Abs[f[(x2^2),x2]])/(Sqrt[(x2^4)+(x2^2)])),x2->0]

Exercise 2.11

Clear["`*"]
Off[General::spell1]
lightblue=RGBColor[220/256,248/256,248/256];
rmin=0.001;
rmax=1;
αmin=0;
αmax=2π;
nr=89;
nα=155;
f[x1_,x2_]:=((x1^3)/((x1^2)+(x2^2)))
D1f[x1_,x2_]:=(∂_x1) f[x1,x2]
D2f[x1_,x2_]:=(∂_x2) f[x1,x2]
x1[r_,α_]:=r Cos[α]
x2[r_,α_]:=r Sin[α]
x3[r_,α_]:=f[x1[r,α],x2[r,α]]
parametricPlot3D[{x1[r,α],x2[r,α],x3[r,α]}//Evaluate,{r,rmin,rmax},{α,αmin,αmax},PlotPoints->{nr,nα},ViewPoint->{0.8,1,3},lightSources->{{{-1,-2,0},RGBColor[0,0,1]},{{0,0,1},RGBColor[1,0,0]},{{-1,0,1},RGBColor[0,1,0]},{{1,-3,-3},RGBColor[1,.3,0]}},Boxed->False,Axes->False,Ticks->None,PlotRange->{{-0.5,0.5},{-0.5,0.5},{-0.25,0.25}},Background->lightblue,ImageSize->1200];
D1f[(Subscript[x, 1]),(Subscript[x, 2])]
Simplify[D1f[x1,x2]==1+(x2^2)(((x1^2)-(x2^2))/((((x1^2)+(x2^2)))^2))]
D2f[(Subscript[x, 1]),(Subscript[x, 2])]
Clear[x3]
x3[r_,α_]:=D1f[y1,y2]/.{y1->x1[r,α],y2->x2[r,α]}
parametricPlot3D[{x1[r,α],x2[r,α],x3[r,α]}//Evaluate,{r,rmin,rmax},{α,αmin,αmax},PlotPoints->{nr,nα},ViewPoint->{0.8,1,3},Boxed->False,Axes->False,Ticks->None,PlotRange->{{-0.5,0.5},{-0.5,0.5},{0,1.3}},Background->lightblue,ImageSize->1200];
Clear[x3]
x3[r_,α_]:=D2f[y1,y2]/.{y1->x1[r,α],y2->x2[r,α]}
parametricPlot3D[{x1[r,α],x2[r,α],x3[r,α]}//Evaluate,{r,rmin,rmax},{α,αmin,αmax},PlotPoints->{nr,nα},ViewPoint->{0.8,1,3},Boxed->False,Axes->False,Ticks->None,PlotRange->{{-0.5,0.5},{-0.5,0.5},{-3/8Sqrt[3]-0.1,3/8Sqrt[3]+0.1}},Background->lightblue,ImageSize->1200];

Exercise 2.17

Clear["`*"]
f[x1_,x2_]:=x1 g[(x2/x1)]+h[(x2/x1)]
fullSimplify[x1^2 (∂_(x1,x1))f[x1,x2]+2x1 x2 (∂_(x1,x2))f[x1,x2]+x2^2 (∂_(x2,x2))f[x1,x2]]

Exercises 2.19 and 2.20

See the computations in Section 2.4   Chain rule above.

Exercise 2.22

See the file Ex2.22.pdf

Exercise 2.25

See the file Ex2.25.pdf

Exercises 2.29

Mathematica produces many spurious solutions, due to limitations in machine precision.

Clear["`*"]
Off[Divide::infy]
Off[∞::indet]
Off[FindRoot::cvmit]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
f[x_]:=Log[1+(E^x)]
Simplify[f'[x]<1,Im[x]==0]
Simplify[f[x]==x+f[-x],Im[x]==0]
g=plot[f[x],{x,-1,10},AspectRatio->Automatic,PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,Ticks->None,plotPoints->1000,DisplayFunction->None];
b=plot[x,{x,-1,10},AspectRatio->Automatic,PlotStyle->darkblue,AxesStyle->RGBColor[0,0.5,0],Background->lightblue,Ticks->None,plotPoints->1000,DisplayFunction->None];
show[b,g,DisplayFunction->$DisplayFunction,ImageSize->500];
r[0]=FindRoot[f[-x]==0,{x,10},WorkingPrecision->$MachinePrecision]
f[x]-x/.r[0]
r[n_]:=FindRoot[f[-x]==0,{x,n},WorkingPrecision->$MachinePrecision]
Table[f[x]-x/.r[n],{n,111,130}]

Exercises 2.30

Mathematica can compute the gradient of a function in the case of (R^2)or (R^3)using a package.

Clear["`*"]
Off[General::obspkg];
<<VectorAnalysis`

Grad[f[x1,x2,x3] ,Cartesian[x1,x2,x3]]/.Thread[{x1,x2,x3}->{(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])}]
f[x1_,x2_,x3_]:=Log[(Sqrt[(x1^2)+(x2^2)])]
Grad[f[x1,x2,x3] ,Cartesian[x1,x2,x3]]/.Thread[{x1,x2}->{(Subscript[x, 1]),(Subscript[x, 2])}]
f[x1_,x2_,x3_]:=((-1)/(Sqrt[(x1^2)+(x2^2)+(x3^2)]))
Grad[f[x1,x2,x3] ,Cartesian[x1,x2,x3]]/.Thread[{x1,x2,x3}->{(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])}]

Exercise 2.31

See the file Ex2.31.pdf

Exercise 2.36

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
f[x1_,x2_]:=((x1^2)-x2)(3(x1^2)-x2)
x1[r_,α_]:=r Cos[α]
x2[r_,α_]:=r Sin[α]
x3[r_,α_]:=f[x1[r,α],x2[r,α]]
p[r_,α_]:={x1[r,α],x2[r,α],x3[r,α]}
f[t,(t^2)]
f[t,2(t^2)]
f[t,3(t^2)]
f[t,4(t^2)]
plot[{(t^2),2(t^2),3(t^2),4(t^2)},{t,-0.3,0.3},PlotRange->{-0.05,0.3},AspectRatio->Automatic,PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,Ticks->None,ImageSize->600];
parametricPlot3D[Append[p[r,α],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{r,0,2},{α,0,2π},PlotPoints->51,lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},ViewPoint->2{0.7,1.1,0.4},PlotRange->{{-1.1,1.1},{-0.9,0.9},{-0.5,0.6}},Boxed->False,Axes->None,Background->lightblue,ImageSize->1100];
Print["Part (i)"]
plot[f[0,t],{t,-0.5,0.5},PlotRange->{-0.05,0.3},AspectRatio->Automatic,PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,Ticks->None,ImageSize->600];
plot[f[t,2(t^2)],{t,-0.5,0.5},PlotRange->{-0.1,0.05},AspectRatio->Automatic,PlotStyle->RGBColor[1,0,0],Axes->True,AxesStyle->RGBColor[0,0.5,0],Background->lightblue,Ticks->None,ImageSize->600];
Print["Part (ii)"]
g[x1_]:=f[x1,λ x1]
λ=2;
plot[g[(Subscript[x, 1])],{(Subscript[x, 1]),-1,3},PlotRange->{-3,1},AspectRatio->Automatic,PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,Ticks->None,ImageSize->600];
Clear[λ]
sol=Flatten[Solve[(∂_(Subscript[x, 1])) g[(Subscript[x, 1])]==0,(Subscript[x, 1])]]
Print["Local minimum at 0"]
x1=(Subscript[x, 1])/.sol[[1]]
g[x1]
Print["Local minimum"]
x3=Simplify[(Subscript[x, 1])/.sol[[3]]]
Simplify[g[x3]]
Print["Local maximum"]
x2=Simplify[(Subscript[x, 1])/.sol[[2]]]
Simplify[g[x2]]

Exercise 2.39

See the file Ex2.39.pdf

Exercise 2.47

Clear["`*"]
f[x_,y_]:=(x^2)-y
x0=5.5;
x00=x0+1;
y0=2;
x1=(x0+y0/x0)/2;
x11=x1+1;
x2=(x1+y0/x1)/2;
z0=5.5;
z00=z0+1;
A=1/(2 z0);
z1=z0-A f[z0,y0];
z2=z1-A f[z1,y0];
z3=z2-A f[z2,y0];
lightblue=RGBColor[220/256,248/256,248/256];

plot[f[x,y0],{x,Sqrt[y0]-1,Sqrt[y0]+5.5},plotPoints->50,PlotStyle->{AbsoluteThickness[0.75],RGBColor[1,0,0]},Background->lightblue,DisplayFunction->None];
Graphics[{AbsoluteThickness[1],Line[{{Sqrt[y0]-1,0},{Sqrt[y0]+5,0}}],{RGBColor[0,0,1],Line[{{x1,0},{x00,f[x0,y0]+2 x0 (x00-x0)}}]},{RGBColor[0,0,1],Line[{{x2,0},{x11,f[x1,y0]+2 x1 (x11-x1)}}]},Text["a",{x0,-0.5}],Text["b",{x1,-.5}],Text["c",{x2,-0.5}],{Dashing[{0.01,0.01}],AbsoluteThickness[0.5],Line[{{x0,0},{x0,f[x0,y0]}}],Line[{{x1,0},{x1,f[x1,y0]}}]}}];
show[%%,%,Axes->None,DisplayFunction->None];
plot[f[x,y0],{x,Sqrt[y0]-1,Sqrt[y0]+5.5},plotPoints->50,PlotStyle->{AbsoluteThickness[0.75],RGBColor[1,0,0]},Background->lightblue,DisplayFunction->None];
Graphics[{AbsoluteThickness[1],Line[{{Sqrt[y0]-1,0},{Sqrt[y0]+5,0}}],{RGBColor[0,0,1],Line[{{z1,0},{z00,f[z0,y0]+1/A (z00-z0)}}]},{RGBColor[0,0,1],Line[{{z2,0},{z1,f[z1,y0]}}],Line[{{z3,0},{z2,f[z2,y0]}}]},Text["d",{z0,-.5}],Text["e",{z1,-.5}],Text["f",{z2,-.5}],Text["g",{z3,-0.5}],{Dashing[{0.01,0.01}],AbsoluteThickness[0.5],Line[{{z0,0},{z0,f[z0,y0]}}],Line[{{z1,0},{z1,f[z1,y0]}}],Line[{{z2,0},{z2,f[z2,y0]}}],Line[{{z3,0},{z3,f[z3,y0]}}]}}];
show[%%,%,Axes->None,DisplayFunction->None];
show[GraphicsGrid[{{%,%%%%}}],ImageSize->1100];

We give a concrete application of Newton's iteration method.

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
plot[{2x,Tan[x]},{x,0,(π/2)},PlotRange->{0,3},Background->lightblue,PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],AspectRatio->Automatic,ImageSize->400];
plot[{2x,Tan[x]},{x,1.165561,1.1655615},Background->lightblue,PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],AspectRatio->Automatic,ImageSize->400];
f[x_]:=2x-Tan[x]
F[x_]:=N[x-(1/(f'[x]))f[x],150]
Print["The nontrivial zero"]
FixedPoint[F,(6/5)]
f[%]
FixedPointList[F,(6/5)]
Table[Abs[%[[k+1]]-%[[k]]],{k,Length[%]-1}]
FindRoot[f[x]==0,{x,(6/5)}]
Print["The trivial zero"]
FixedPoint[F,(1/5)]
f[%]
FixedPointList[F,(1/5)]
Table[Abs[%[[k+1]]-%[[k]]],{k,Length[%]-1}]

Exercise 2.79

Clear["`*"]
Integrate[(( 1)/(1+p  Cos[α])),{α,0,π},Assumptions->{-1<p<1}]
Integrate[ ((Log[1+x  Cos[α]])/(Cos[α])),{α,0,π},Assumptions->{-1<x<1}]

Exercise 2.80

Mathematica is able to evaluate only the first two of the three integrals in the exercise, in case of the third it is not able to produce the compact form of the answer.

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
Integrate[(1/(1-(a^2) (y^2)((Sin[x])^2))),{x,0,(π/2)},Assumptions->{0<a<1,0<y<1}]
Integrate[(1/(1-(a^2) (y^2)((Sin[x])^2))),{y,0,1},Assumptions->{0<a<1,x∈Reals}]
FullSimplify[TrigExpand[%]==(1/(2a Sin[x]))Log[((1+a Sin[x])/(1-a Sin[x]))],Assumptions->{0<a<1,Im[x]==0}]
f[a_]:=Integrate[(1/(Sin[x])) Log[((1+a Sin[x])/(1-a Sin[x]))],{x,0,(π/2)},Assumptions->{0<a<1}] 
f[a]
g[a_]:=π ArcSin[a]-f[a]
fullSimplify[g[a],Assumptions->{0<a<1}]
fullSimplify[(∂_a) g[a],{0<a<1}]
g[(1/2)]
plot[Evaluate[g[a]],{a,0,1},PlotStyle->RGBColor[1,0,0],PlotPoints->500,PlotRange->All,AxesStyle->RGBColor[0,0.5,0],Background->lightblue,ImageSize->800];

Exercise 2.82

Clear["`*"]
Integrate[ ((1-Cos[x t])/(t^2)),{t,0,∞},Assumptions->{Im[x]==0}]
Integrate[ (((Sin[x t])^2)/(t^2)),{t,0,∞},Assumptions->{Im[x]==0}]
Integrate[(( ((Sin[x t])^4))/(t^2)),{t,0,∞},Assumptions->{Im[x]==0}]
Integrate[ (((Sin[x t])^4)/(t^4)),{t,0,∞},Assumptions->{Im[x]==0}]

Exercise 2.85

Clear["`*"]
TrigExpand[Integrate[((Sin[x t])/(t(1+(t^2)))),{t,0,∞},Assumptions->{x>0}]]
Integrate[((Cos[x t])/(1+(t^2))),{t,0,∞},Assumptions->{x>0}]
Integrate[((t Sin[x t])/(1+(t^2))),{t,0,∞},Assumptions->{x>0}]

Exercise 2.86

Clear["`*"]
Integrate[ ((Log[1+(x^2)(t^2)])/(1+(t^2))),{t,0,∞},Assumptions->{x≥0}]

Exercise 2.87

Clear["`*"]
"Part (i)"
Integrate[(E^(-(t^2)-(x^2)/(t^2))),{t,0,∞},Assumptions->{x>0}]
"Part (ii)"
(Sqrt[x])Integrate[(E^(-x((t^2)+(t^(-2))))),{t,0,∞},Assumptions->{x>0}]
"Part (v)"
Integrate[(1/(Sqrt[t]))(E^(-(a^2)t-(b^2)/t)),{t,0,∞},Assumptions->{a>0,b>0}]
Integrate[(1/(t (Sqrt[t])))(E^(-(a^2)t-(b^2)/t)),{t,0,∞},Assumptions->{a>0,b>0}]
Integrate[(1/(Sqrt[π])) ((E^(-t))/(Sqrt[t])) (E^(-(x^2)/(4t))),{t,0,∞},Assumptions->{x>0}]

Exercise 2.88

Clear["`*"]
Off[N::meprec]
Simplify[Integrate[((ArcTan[x t])/(t (Sqrt[1-(t^2)]))),{t,0,1}],x>0]
fullSimplify[TrigExpand[ArcSinh[x]]==Log[x+(Sqrt[1+(x^2)])]]
fullSimplify[TrigExpand[(π/2) ArcSinh[1]]==(π/2) Log[1+(Sqrt[2])]]

Exercise 2.89

Clear["`*"]
Off[N::meprec]
Integrate[(1/(1+(t^2)(y^2))),{y,0,1},Assumptions->{Im[t]==0,t≠0}]
Limit[%,t->0]
(π/2) Integrate[(1/(Sqrt[1+(y^2)])),{y,0,1}]
fullSimplify[ TrigExpand[%]==(π/2)Log[1+(Sqrt[2])]]

Exercise 2.90   (Airy function)

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
AiryAi''[x]-x AiryAi[x]
AiryAi[0]
fullSimplify[AiryAi[0]-((Gamma[(1/3)])/(2π (3^(1/6))))]
AiryAi'[0]
fullSimplify[AiryAi'[0]+(((3^(1/6))Gamma[(2/3)])/(2π ))]
fullSimplify[Series[AiryAi[x],{x,0,11}]-AiryAi[0](1+(1/(3!))(x^3)+((1 4)/(6!))(x^6)+((1 4 7)/(9!))(x^9))-AiryAi'[0](x+(2/(4!))(x^4)+((2 5)/(7!))(x^7)+((2 5 8)/(10!))(x^10))]
plot[AiryAi[x],{x,-30,7},plotPoints->10000,PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,ImageSize->700];

CHAPTER 3: EXERCISES

Exercise 3.1

Clear["`*"]
Flatten[Solve[{(Subscript[y, 1])+(Subscript[y, 2])==(Subscript[x, 1]),((Subscript[y, 1])/(Subscript[y, 2]))==(Subscript[x, 2])},{(Subscript[y, 1]),(Subscript[y, 2])}]]/.{Rule->Equal}

Exercise 3.2

Clear["`*"]
Flatten[Solve[{(Subscript[y, 1]) (Subscript[y, 2])==(Subscript[x, 1]),(1-(Subscript[y, 1]))(Subscript[y, 2])==(Subscript[x, 2])},{(Subscript[y, 1]),(Subscript[y, 2])}]]/.{Rule->Equal}

Exercise 3.3

Clear["`*"]
Flatten[Simplify[Solve[{(Subscript[x, 1])+(Subscript[x, 2])==(Subscript[y, 1]),(Subscript[x, 1])-(Subscript[x, 2])==(Subscript[y, 2])},{(Subscript[x, 1]),(Subscript[x, 2])}]]]/.{Rule->Equal}

Exercise 3.7

Clear["`*"]
t0= π/4;
s0=0.3 π;
r=1;
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];

p1=Graphics3D[{{RGBColor[1,0,0],AbsolutePointSize[5],Point[{0,0,r Sin[t0]}],Point[{r Cos[t0] Cos[s0],r Cos[t0] Sin[s0],r Sin[t0]}],Point[{0,r Cos[t0] Sin[s0],0}],Point[{r Cos[t0] Cos[s0],0,0}]},
{darkblue,AbsoluteThickness[1],Line[{{0,0,r Sin[t0]},{r Cos[t0] Cos[s0],r Cos[t0] Sin[s0],r Sin[t0]},{r Cos[t0] Cos[s0],r Cos[t0] Sin[s0],0}}],Line[{{r Cos[t0] Cos[s0],0,0},{r Cos[t0] Cos[s0],r Cos[t0] Sin[s0],0},{0,r Cos[t0] Sin[s0],0}}],Line[{{0,0,0},{r Cos[t0] Cos[s0],r Cos[t0] Sin[s0],0}}],Line[{{0,0,0},{r Cos[t0] Cos[s0],r Cos[t0] Sin[s0],r Sin[t0]}}]},Text["d",{0,0,r Sin[t0]}],Text["r",{3 r/4 Cos[t0] Cos[s0],3 r/4 Cos[t0] Sin[s0],3 r/4 Sin[t0]}],Text["c",{0,r Cos[t0] Sin[s0],0}],Text["b",{r Cos[t0] Cos[s0],0,0}],Text["a",{0.25 Cos[s0/2],0.25 Sin[s0/2],0}],Text["t",{0.25 Cos[t0/2] Cos[s0],0.25 Cos[t0/2] Sin[s0],0.25 Sin[t0/2]}]}];
p2=Graphics3D[{{RGBColor[0,0.5,0],AbsoluteThickness[0.75],Line[{{1,0,0},{0,0,0},{0,1,0}}],Line[{{0,0,0},{0,0,1}}]},{darkblue,AbsoluteThickness[1],Line[{{0,0,r Sin[t0]},{r Cos[t0] Cos[s0],r Cos[t0] Sin[s0],r Sin[t0]},{r Cos[t0] Cos[s0],r Cos[t0] Sin[s0],0}}],Line[{{r Cos[t0] Cos[s0],0,0},{r Cos[t0] Cos[s0],r Cos[t0] Sin[s0],0},{0,r Cos[t0] Sin[s0],0}}],Line[{{0,0,0},{r Cos[t0] Cos[s0],r Cos[t0] Sin[s0],0}}],Line[{{0,0,0},{r Cos[t0] Cos[s0],r Cos[t0] Sin[s0],r Sin[t0]}}]},Text["d",{0,0,r Sin[t0]}],Text["r",{3 r/4 Cos[t0] Cos[s0],3 r/4 Cos[t0] Sin[s0],3 r/4 Sin[t0]}],Text["c",{0,r Cos[t0] Sin[s0],0}],Text["b",{r Cos[t0] Cos[s0],0,0}],Text["a",{0.25 Cos[s0/2],0.25 Sin[s0/2],0}],Text["t",{0.25 Cos[t0/2] Cos[s0],0.25 Cos[t0/2] Sin[s0],0.25 Sin[t0/2]}]}];
p3=parametricPlot3D[Append[{0.25 Cos[s],0.25 Sin[s],0},RGBColor[1,0,0]],{s,0,s0},plotPoints->100,DisplayFunction->None];
p4=parametricPlot3D[Append[{0.25 Cos[t] Cos[s0],0.25 Cos[t] Sin[s0],0.25 Sin[t]},RGBColor[1,0,0]],{t,0,t0},plotPoints->100,DisplayFunction->None];
show[p1,p2,p3,p4,Boxed->False,ViewPoint->{200,100,100},PlotRange->{{0,0.7},{0,1},{0,1}},BaseStyle->Large,defaultFont->12.,Background->lightblue,ImageSize->600,DisplayFunction->$DisplayFunction];

Exercise 3.11   (Confocal coordinates)

See the file Ex3.11.pdf

Exercises 3.12 and 3.14   (Gradient and divergence in arbitrary coordinates)

Mathematica can compute the gradient of a function and the divergence of a vector field in certain special coordinates in the case of (R^3) using a package. Below we give an example.

Clear["`*"]
Off[General::obspkg];
<<VectorAnalysis`
SetCoordinates[ProlateSpheroidal];
{CoordinateSystem,Coordinates[]}
CoordinatesFromCartesian[{x,y,z},ProlateSpheroidal]   
Grad[f[x,e,p],ProlateSpheroidal[x,e,p]]
Laplacian[f[x,e,p],ProlateSpheroidal[x,e,p]]
Div[{(Subscript[f, 1])[x,e,p],(Subscript[f, 2])[x,e,p],(Subscript[f, 3])[x,e,p]},ProlateSpheroidal[x,e,p]]
Curl[{(Subscript[f, 1])[x,e,p],(Subscript[f, 2])[x,e,p],(Subscript[f, 3])[x,e,p]},ProlateSpheroidal[x,e,p]]

Exercise 3.20   (Diffeomorphism of triangle onto square)

Clear["`*"]
y1[x1_,x2_]:=ArcTan[x1 (Sqrt[((1-(x2^2))/(1-(x1^2)))])]
y2[x1_,x2_]:=y1[x2,x1]
y2[(Subscript[x, 1]),(Subscript[x, 2])]
PowerExpand[Simplify[{((Sin[y1[(Subscript[x, 1]),(Subscript[x, 2])]])/(Cos[y2[(Subscript[x, 1]),(Subscript[x, 2])]])),((Sin[y2[(Subscript[x, 1]),(Subscript[x, 2])]])/(Cos[y1[(Subscript[x, 1]),(Subscript[x, 2])]]))},{Im[(Subscript[x, 1])]==0,Im[(Subscript[x, 2])]==0}]]

Exercise 3.22   (Wave equation in one spatial variable)

u[x_,t_]=(1/2)(f[x+t]+f[x-t])+(1/2)(∫_(x-t)^(x+t))g[y]\[DifferentialD]y;
{u[x,0],(∂_t) u[x,t]}/.t->0
Simplify[(∂_(t,t))u[x,t]-(∂_(x,x))u[x,t]]

Exercise 3.31

Clear["`*"]
f[x_,y_]:=Sin[(x^2)+y]-2x

Print["Part (i)"]
(∂_x) f[x,y]/.{x->0,y->0}
-(1/((∂_x) f[x,y]))(∂_y) f[x,y]/.{x->0,y->0}

Print["Part (ii)"]
fy[y_]:=f[x[y],y]
Collect[fy'[y]/.{x[y]->x,x'[y]->x'},x']

Print["Part (iii)"]
Expand[1/2fy''[y]/.{Sin[x[y]^2+y]->2x,x[y]->x,x'[y]->x',x''[y]->x''}]
Flatten[Solve[fy''[y]==0/.{tf[y]->0,x[y]->0,x'[y]->1/2,y->0,x''[y]->x''},x'']]/.{Rule->Equal}

Exercise 3.36

See also the file Ex3.36.pdf

Clear["`*"]
F[x_,a_]:=x-Integrate[f[t],{t,x,a}]
(∂_x) F[x,a]/.x->0
-((((∂_x) F[x,a]))^(-1))(∂_a) F[x,a]/.{x->0,a->b}
f[t_]:=2t-1
Flatten[Simplify[Solve[F[x,a]==0,x]]]/.{Rule->Equal}

Exercise 3.43   (Cardioid)

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];

g[x_,y_]:=(x^4)-4(x^3)+2(y^2)(x^2)-4(y^2)x+(y^4)-4(y^2)
Eliminate[{(Sqrt[(x^2)+(y^2)])==2(1+Cos[α]),(x/(Sqrt[(x^2)+(y^2)]))==Cos[α]},Cos[α]]
Solve[g[x,y]==0,x]

(*<<Graphics`*)
r[α_]:=2(1+Cos[α])
p1=PolarPlot[r[α],{α,-π,π},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,Axes->True,Ticks->None,DisplayFunction->Identity];

(*<<Graphics`Contourplot`*)p2=ContourPlot[g[x,y]==0,{x,-1,4},{y,-2.6,2.6},Axes->True,AxesStyle->RGBColor[0,0.5,0],Ticks->None,Background->lightblue,ColorFunction->(Red&),Frame->None,DisplayFunction->Identity];

p3=parametricPlot[r[α]{ Cos[α], Sin[α]},{α,0,2 π},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,plotPoints->50,AspectRatio->1,Ticks->None,DisplayFunction->None];

show[GraphicsGrid[{{p1,p2,p3}}],ImageSize->1200,DisplayFunction->$DisplayFunction];

Exercise 3.45   (Discriminant locus)

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];

f[x_]:=(Subscript[y, 2]) (x^2)+(Subscript[y, 1]) x+(Subscript[y, 0])
Eliminate[{f[x]==0,(∂_x) f[x]==0},x]
Simplify[%/.Thread[{(Subscript[y, 0]),(Subscript[y, 1]),(Subscript[y, 2])}->{((Subscript[z, 2])+(Subscript[z, 0]))/2,(Subscript[z, 1]),((Subscript[z, 2])-(Subscript[z, 0]))/2}]]

Print["Cone  ((Subscript[y, 1])^2)-(Subscript[y, 0])(Subscript[y, 2])=0"]
(*<<Graphics`contourPlot3D`*)
contourPlot3D[(y1^2)-4y0 y2,{y0,-4,4},{y1,-6,6},{y2,-4,4},ContourStyle->RGBColor[0.7,0.7,1],lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[0,0,1]},{{0,2,2},RGBColor[0,1,1]}},PlotPoints->20,ViewPoint->{1,0.5,-0.3},Background->lightblue,Boxed->False,ImageSize->1000]

Print["Cone  ((Subscript[z, 0])^2)+((Subscript[z, 1])^2)-((Subscript[z, 2])^2)=0"]
x[α_,t_]:=t{Cos[α],Sin[α],1};
co=parametricPlot3D[Append[x[α,t],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{α,-π,π},{t,-3,3},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},plotPoints->{121,121},Axes->False,PlotRange->All,BoxRatios->{1,1,1},Boxed->False,Background->lightblue,DisplayFunction->None];
view={2,2,1};
show[co,PlotRange->All,Axes->False,BoxRatios->{1,1,1},AspectRatio->1,Boxed->False,ViewPoint->view,ImageSize->1000,DisplayFunction->$DisplayFunction];

The following is time-consuming. For orientation of the reader, the point (3,0,3) has been made visible.

Clear["`*"]
Off[General::spell]
Off[General::spell1]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
x[α_,t_]:=t{Cos[α],Sin[α],1};
raster1=π/100;
raster2=0.03;
point=0.001;
listc=Table[{darkblue,Point[x[α,t]]},{α,-π+raster1,π,raster1},{t,-3,3,raster2}];
listt=Table[{RGBColor[1,0,0],Point[x[α,3]]},{α,-π+raster1,π,raster1}];
listb=Table[{RGBColor[1,0,0],Point[x[α,-3]]},{α,-π+raster1,π,raster1}];
po=Graphics3D[{PointSize[12point],RGBColor[1,0,0],Point[x[0,3]]},AspectRatio->1,Boxed->False,DisplayFunction->None];
co=Graphics3D[{PointSize[point],listc},Axes->False,PlotRange->All,AspectRatio->1,Boxed->False,DisplayFunction->None];
ct=Graphics3D[{PointSize[5point],listt},Axes->False,PlotRange->All,AspectRatio->1,Boxed->False,DisplayFunction->None];
cb=Graphics3D[{PointSize[5point],listb},Axes->False,PlotRange->All,AspectRatio->1,Boxed->False,DisplayFunction->None];
view={2,2,1};
show[po,co,ct,cb,PlotRange->All,Axes->False,BoxRatios->{1,1,1},AspectRatio->1,Boxed->False,ViewPoint->view,ImageSize->700,Background->lightblue,lightSources->{{{1,0,1},RGBColor[1,0,0]},{{1,1,1},RGBColor[0,1,0]},{{0,1,1},RGBColor[0,0,1]}},DisplayFunction->$DisplayFunction];

CHAPTER 4: EXERCISES

Exercise 4.2

In the first illustration below, Mathematica adds the two asymptotes without due cause, which therefore are removed by hand.

Clear["`*"]
Off[Eliminate::ifun]
lightblue=RGBColor[220/256,248/256,248/256];

Print["From polar to Cartesian coordinates"]
(*<<Graphics`Graphics`;*)
r[α_]:=(6/(1-2Cos[α]))
p1=PolarPlot[r[α],{α,-π,π},PlotStyle->RGBColor[1,0,0],Axes->None,Background->lightblue,DisplayFunction->Identity];
p2=show[p1//.Line[{a___,b:{_,y1_},c:{_,y2_},d___}]:>Sequence[Line[{a,b}],Line[{c,d}]]/;Abs[y1-y2]>10,PlotRange->{-10,10},DisplayFunction->None];
Eliminate[{(Sqrt[((Subscript[x, 1])^2)+((Subscript[x, 2])^2)])==(6/(1-2Cos[α])),((Subscript[x, 1])/(Sqrt[((Subscript[x, 1])^2)+((Subscript[x, 2])^2)]))==Cos[α]},Cos[α]]

Print["From Cartesian to polar coordinates and back"]
(*<<Graphics`Contourplot`*)
g[x1_,x2_]:=3(x1^2)+24x1-(x2^2)+36
p3=ContourPlot[g[x1,x2]==0,{x1,-10.1,2.1},{x2,-10.1,2.1},Axes->None,Background->lightblue,DisplayFunction->Identity];
Eliminate[{g[x1,x2]==0,x1==r Cos[α],x2==-r (Sqrt[1-((Cos[α])^2)])},{x1,x2}]
Simplify[g[x1,x2]==3(((x1+4))^2)-(x2^2)-12]
Simplify[g[x1,x2]/.Thread[{x1,x2}->{-4+2Cosh[t],Sqrt[12]Sinh[t]}]]

Print["From equation to parametrization and polar coordinates"]
phi[t_]:={-4+2Cosh[t],2(Sqrt[3])Sinh[t]}
p4=parametricPlot[phi[t],{t,-2,2},AspectRatio->Automatic,Axes->None,PlotStyle->RGBColor[1,0,0],Background->lightblue,ImageSize->1200,DisplayFunction->None];
Simplify[3((phi[t][[1]])^2)+24phi[t][[1]]-((phi[t][[2]])^2)+36]
Eliminate[{(Subscript[x, 1])+4==2Cosh[t],(Subscript[x, 2])==(Sqrt[12])Sinh[t]},t]
Eliminate[{x1+4==2Cosh[t],x2==(Sqrt[12])Sinh[t],x1==r Cos[α],x2==r Sin[α]},{x1,x2,t}]
Solve[Simplify[%/.((Sin[α])^2)->1-((Cos[α])^2)],r][[1]]/.{Rule->Equal}

Print["Branch of hyperbola"]
show[GraphicsGrid[{{p2,p3,p4}}],ImageSize->600,DisplayFunction->$DisplayFunction];

Exercise 4.4   (Cycloid)

Clear["`*"]
Off[Solve::tdep]
Print["Part (i)"]
ϕ[t_]:={t-Sin[t],1-Cos[t]}
Solve[ϕ[t]==ϕ[u],{t,u}]
Reduce[ϕ[t][[2]]==ϕ[u][[2]],t]
Simplify[%[[2]],{0<u<π}] 
Solve[{ϕ[t][[1]]==ϕ[t+2π][[1]]},t]
Solve[{ϕ[t][[1]]==ϕ[t-2π][[1]]},t]

Exercise 4.5

Clear["`*"]
Off[General::spell1]
amin=-π;
amax=π;
tmin=-π;
tmax=π;
na=101;
nt=301;
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];

Print["Part (i)"]
ϕ[α_,θ_]:={Cos[α]Cos[θ],Sin[α]Cos[θ],Sin[θ]}
MatrixForm[ϕ[α,θ]]
Simplify[Eliminate[{(Subscript[x, 1])==ϕ[α,θ][[1]],(Subscript[x, 2])==ϕ[α,θ][[2]],(Subscript[x, 3])==ϕ[α,θ][[3]]},{α,θ}]]
parametricPlot3D[Append[ϕ[α,θ],SurfaceColor[RGBColor[0.7,0.7,1]]]//Evaluate,{α,amin,amax},{θ,tmin,tmax},lightSources->{{2{1,0,0},RGBColor[1,0,0]},{2{1,0,0},RGBColor[1,0,0]},{2{-1,0,0},RGBColor[1,0,0]},{2{0,1,0},RGBColor[1,1,0]},{2{0,2,2},RGBColor[0,1,1]}},Background->lightblue,plotPoints->{na,nt},ViewPoint->{1,2,0.8},PlotRange->{{-1.1,1.1},{-1.1,1.1},{-1.1,1.1}},Boxed->False,Ticks->None,Axes->None,ImageSize->1000];

Print["Part (ii)"]
(j=Transpose[{(∂_α) ϕ[α,θ],(∂_θ) ϕ[α,θ]}])//MatrixForm

Print["Part (iii)"]
pt=Table[parametricPlot3D[ϕ[α,θ]//Evaluate,{α,amin,amax},BaseStyle->RGBColor[1,0,0],Background->lightblue,plotPoints->nt,ViewPoint->{1,2,0.8},PlotRange->{{-1.1,1.1},{-1.1,1.1},{-1.1,1.1}},ColorFunction->(RGBColor[1,0,0]&),Boxed->False,Ticks->None,Axes->None,DisplayFunction->None],{θ,tmin,tmax,π/80}];
show[pt,ImageSize->1000,BaseStyle->RGBColor[1,0,0],DisplayFunction->$DisplayFunction];

pa=Table[parametricPlot3D[ϕ[α,θ]//Evaluate,{θ,tmin,tmax},BaseStyle->darkblue,Background->lightblue,plotPoints->nt,ViewPoint->{1,2,0.8},PlotRange->{{-1.1,1.1},{-1.1,1.1},{-1.1,1.1}},Boxed->False,Ticks->None,Axes->None,DisplayFunction->None],{α,amin,amax,π/80}];
show[pa,ImageSize->1000,DisplayFunction->$DisplayFunction];

Exercise 4.6   (Surfaces of revolution)

Clear["`*"]
Off[General::spell1]
Off[Eliminate::ifun]
smin=-3;
smax=3;
tmin=-π;
tmax=π;
ns=101;
nt=301;
lightblue=RGBColor[220/256,248/256,248/256];

Print[Catenary]
γ[s_]:={Cosh[s],0,s}
parametricPlot3D[{γ[s],RGBColor[1,0,0]},{s,smin,smax},BaseStyle->{Red},ColorFunction->(Red&),Background->lightblue,plotPoints->ns,ViewPoint->{1,2,0.8},PlotRange->{{-2,2},{-2,2},{-1.2,1.2}},Boxed->True,Ticks->None,Axes->None,ImageSize->600];

Print[Catenoid]
ϕ[s_,t_]:={γ[s][[1]]Cos[t],γ[s][[1]]Sin[t],γ[s][[3]]}
parametricPlot3D[Append[ϕ[s,t],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{s,smin,smax},{t,tmin,tmax},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},Background->lightblue,plotPoints->{ns,nt},ViewPoint->{1,2,0.8},PlotRange->{{-2,2},{-2,2},{-1.2,1.2}},Boxed->False,Ticks->None,Axes->None,ImageSize->1000]; 

Print["Part (ii)"]
γ[s_]:={(Subscript[γ, 1])[s],0,(Subscript[γ, 3])[s]}
ϕ[s,t]//MatrixForm
(j=Transpose[{(∂_s) ϕ[s,t],(∂_t) ϕ[s,t]}])//MatrixForm
fullSimplify[-Sin[t]j[[1,2]]+Cos[t]j[[2,2]]==0]

Print["Part (iv)"]
γ[s_]:={(s^3),0,s}
parametricPlot3D[γ[s],{s,smin,smax},BaseStyle->RGBColor[1,0,0],ColorFunction->(Red&),Background->lightblue,plotPoints->ns,ViewPoint->{1,2,0.8},PlotRange->{{-2,2},{-2,2},{-1.2,1.2}},Boxed->True,Ticks->None,Axes->None,ImageSize->600];
parametricPlot3D[Append[ϕ[s,t],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{s,smin,smax},{t,tmin,tmax},lightSources->{{{1,1,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,2,0},RGBColor[1,1,0]},{2{0,2,2},RGBColor[0.2,.5,.7]}},Background->lightblue,plotPoints->{ns,nt},ViewPoint->{1,2,0.8},PlotRange->{{-2,2},{-2,2},{-1.2,1.2}},Boxed->False,Ticks->None,Axes->None,ImageSize->1000]; 
γ[s_]:={(Sqrt[s]),0,s}
parametricPlot3D[γ[s],{s,0,smax},BaseStyle->RGBColor[1,0,0],ColorFunction->(Red&),Background->lightblue,plotPoints->ns,ViewPoint->{1,2,0.8},PlotRange->{{-2,2},{-2,2},{0,2}},Boxed->True,Ticks->None,Axes->None,ImageSize->600];
parametricPlot3D[Append[ϕ[s,t],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{s,0,smax},{t,tmin,tmax},lightSources->{{2{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},Background->lightblue,plotPoints->{ns,nt},ViewPoint->{1,2,0.8},PlotRange->{{-2,2},{-2,2},{0,2}},Boxed->False,Ticks->None,Axes->None,ImageSize->1000]; 

Print["Part (v)"]
Eliminate[{x1==a Cosh[s]Cos[t],x2==a Cosh[s]Sin[t],x3==a s},{s,t}]/.Thread[{x1,x2,x3}->{(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])}]
Eliminate[{x1==a Cosh[s]Cos[t],x2==a Cosh[s]Sin[t],x3==a s},{s,t}][[6]]/.Thread[{x1,x2,x3}->{(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])}];
(%/.{s->x3/a})/.Thread[{x1,x2,x3}->{(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])}]

Exercise 4.8   (Helix and helicoid)

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
helicoid[s_,t_]:={t Cos[s],t Sin[s],s}
helix=parametricPlot3D[Append[helicoid[s,t],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{s,0,((5π)/2)},{t,-6,6},lightSources->{{{2,0,0},RGBColor[.1,0,0]},{{1,0,0},RGBColor[.1,0,0]},{{-2,0,0},RGBColor[1,0,0]},{{0,2,0},RGBColor[1,1,0]},{2{0,-4,4},RGBColor[0,1,.3]},{{0,-4,8},RGBColor[0,0,.3]},{{-2.5,-.5,10},RGBColor[1,1,.0]},{{2.5,.5,10},RGBColor[0,0,.5]}},Axes->None,Boxed->False,ViewPoint->{1,-2,0.8},plotPoints->{55,45},Background->lightblue,ImageSize->800];

Exercise 4.11

Clear["`*"]
Off[General::spell1]
Off[Solve::svars]
lightblue=RGBColor[220/256,248/256,248/256];

g[x1_,x2_]:=(x1^3)-(x2^3)
Print["Part (i)"]
plot[g[x1,0],{x1,-3,3},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,PlotRange->All,ImageSize->700];
Print["Part (ii)"]
j={{(∂_(Subscript[x, 1])) g[(Subscript[x, 1]),(Subscript[x, 2])],(∂_(Subscript[x, 2])) g[(Subscript[x, 1]),(Subscript[x, 2])]}}; 
MatrixForm[j]
First[Solve[j==0,{(Subscript[x, 1]),(Subscript[x, 2])}]]/.{Rule->Equal}
Print["Part (iii)"]
First[Solve[g[(Subscript[x, 1]),(Subscript[x, 2])]==c,{(Subscript[x, 1]),(Subscript[x, 2])}]]
(*<<Graphics`Contourplot`*)
p:=Table[ContourPlot[g[x1,x2]==c,{x1,-4,4},{x2,-4,4},Axes->None,Ticks->None,ColorFunction->(RGBColor[(c+3)/6,0,1-(c+3)/6]&),Background->lightblue,DisplayFunction->Identity],{c,-3,3,1/4}];
show[p,ImageSize->700,DisplayFunction->$DisplayFunction];

Exercise 4.12

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
g[x1_,x2_,x3_]:=(x1^2)+(x2^2)-(x3^2)
Print["Part (i)"]
p1=plot[g[x1,0,0],{x1,0,10},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,DisplayFunction->None];
p2=plot[g[0,0,x3],{x3,0,10},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,DisplayFunction->None];
show[GraphicsGrid[{{p1,p2}}],ImageSize->1200,DisplayFunction->$DisplayFunction];
Print["Part (ii)"]
Flatten[Solve[{{(∂_(Subscript[x, 1])) g[(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])],(∂_(Subscript[x, 2])) g[(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])],(∂_(Subscript[x, 3])) g[(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])]}=={0,0,0}},{(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])}]]/.{Rule->Equal}

Print["Part (iii)  cone  ((Subscript[x, 1])^2)+((Subscript[x, 2])^2)=((Subscript[x, 3])^2)"]
x[α_,t_]:=t{Cos[α], Sin[α],1};
co=parametricPlot3D[x[α,t],{α,-π,π},{t,-3,3},plotPoints->{121,121},Axes->False,PlotRange->All,BoxRatios->{1,1,1},Boxed->False,Background->lightblue,DisplayFunction->None];
view={2,2,1};
show[co,PlotRange->All,Axes->False,BoxRatios->{1,1,1},AspectRatio->1,Boxed->False,ViewPoint->view,ImageSize->700,DisplayFunction->$DisplayFunction];

Exercise 4.14   (Quadrics)

See also the file Ex4.14.pdf. Here a representative example for the case of n=3 is given.

Clear["`*"]
(A={{2,-1,0},{-1,2,-1},{0,-1,2}})//MatrixForm 
Eigenvalues[A]
b={-1,1,1};
co[x_,n_]:=Table[(Subscript[x, j]),{j,n}]
xv=co[x,3];
g[xv_]:=(A.xv).xv+b.xv+c
Expand[g[xv]]
Δ=(Inverse[A].b).b-4c
v=-(1/2)Inverse[A].b

Print["Case of Δ = 0"]
c=(1/2);
Δ
g[v]
Flatten[Solve[{(∂_(Subscript[x, 1])) g[xv],(∂_(Subscript[x, 2])) g[xv],(∂_(Subscript[x, 3])) g[xv]}=={0,0,0},xv]]/.{Rule->Equal}
yv=co[y,3];
xv=yv+v
Simplify[g[xv]]
2((((yv[[1]]-((yv[[2]])/2)))^2)+(((yv[[2]])^2)/2)+(((-((yv[[2]])/2)+yv[[3]]))^2))
Simplify[2((((yv[[1]]-((yv[[2]])/2)))^2)+(((yv[[2]])^2)/2)+(((-((yv[[2]])/2)+yv[[3]]))^2))]
Flatten[Solve[{yv[[1]]-((yv[[2]])/2)==0,yv[[2]]==0,-((yv[[2]])/2)+yv[[3]]==0},{yv[[1]],yv[[2]],yv[[3]]}]]/.{Rule->Equal}

Print["Case of Δ > 0"]
c=0;
Δ=(Inverse[A].b).b-4c
g[v]
Expand[g[xv]]
Simplify[2((((yv[[1]]-((yv[[2]])/2)))^2)+(((yv[[2]])^2)/2)+(((-((yv[[2]])/2)+yv[[3]]))^2))-(1/2)]
(((yv[[1]]-((yv[[2]])/2)))^2)+(((yv[[2]])^2)/2)+(((-((yv[[2]])/2)+yv[[3]]))^2)==(1/4)

Exercise 4.17   (Lines on hyperboloid of one sheet)

Clear["`*"]
Off[General::spell1]
lightblue=RGBColor[220/256,248/256,248/256];
 hplus[a_,b_,c_][s_,t_]:={a Cos[s]-a t Sin[s],b t Cos[s]+b Sin[s],c t}
hminus[a_,b_,c_][s_,t_]:={a Cos[s]+a t Sin[s],-b t Cos[s]+b Sin[s],c t}
p1=parametricPlot3D[  hplus[1,2,3][s,t]//Evaluate,{s,0,2π},{t,-1.5,1.5},Axes->None,Boxed->False,Background->lightblue,DisplayFunction->None];
p2=parametricPlot3D[hminus[1,2,3][s,t]//Evaluate,{s,0,2π},{t,-1.5,1.5},Axes->None,Boxed->False,Background->lightblue,DisplayFunction->None];
show[GraphicsGrid[{{p1,p2}},GraphicsSpacing->0],ImageSize->700,DisplayFunction->$DisplayFunction];

Exercise 4.22   (Rotations in (R^3) and Euler's formula)

Clear["`*"]
Off[General::obspkg];
<<VectorAnalysis`
(*<<LinearAlgebra`Orthogonalization`*)
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
α0=π/6;
b={-0.2,0.7,1.5};
a=Normalize[b];
cp[a_,x_]:= CrossProduct[a,x]
  s[y_]:=Cos[α0] y+Sin[α0]cp[a,x];
  r[x_]:=(1-Cos[α0])(a.x) a+Cos[α0] x+Sin[α0] cp[a,x];
xx[t_]:=(1-Cos[t]) (a.x) a+Cos[t] x+Sin[t] cp[a,x];
yy[t_]:=Cos[t] y+Sin[t] cp[a,x];
x0={-0.6,-0.1,1};
x=Normalize[x0];
y=x-(x.a) a;
p1=Graphics3D[{darkblue,AbsolutePointSize[6],{Point[a],Point[x],Point[(x.a) a],Point[y],Point[s[y]],Point[r[x]],Point[{0,0,0}],Point[cp[a,x]],Line[{a,{0,0,0},y,x,(x.a) a,r[x],s[y],Cos[α0] y,{0,0,0},cp[a,x]}],Line[{{0,0,0},s[y],Sin[α0] cp[a,x]}]},Line[{{0,0,0},x}],Line[{a,{0,0,0}}]}];
p2=Graphics3D[{RGBColor[1,0,0],Line[{x,{0,0,0}}]}];
p3=Graphics3D[{darkblue,{Line[{x-0.85 (x-(x.a) a),x-0.85 (x-(x.a) a)-0.125 (x.a) a,0.875 (x.a) a}],Line[{0.1 (a.x) a,0.1 (a.x) a+0.15 cp[a,x],0.15 cp[a,x]}],Line[{0.15 Cos[α0] y,0.15 Cos[α0] y+0.1 (a.x) a,0.1 (a.x) a}],Line[{0.15 Cos[α0] y,0.15 Cos[α0] y+0.15 cp[a,x],0.15 cp[a,x]}]}}];
p4=Graphics3D[{Text["a",a],Text["x",x],Text["y",y],Text["Rx",r[x]],Text["Ry",s[y]],Text["cy",Cos[α0] y],Text["ax",cp[a,x]],Text["xa",(x.a) a],Text["sax",0.5 cp[a,x]],Text["s",0.5 s[y]]}];
p5=show[p1,p2,p3,p4,Boxed->False,Axes->None,ViewPoint->{1,-3,4},DisplayFunction->None];
p6=parametricPlot3D[Append[xx[t],RGBColor[1,0,0]],{t,0,α0},plotPoints->100,DisplayFunction->None];
p7=parametricPlot3D[Append[yy[t],RGBColor[1,0,0]],{t,0,π/2},plotPoints->100,DisplayFunction->None];
p8=parametricPlot3D[Append[0.4 yy[t],darkblue],{t,0,α0},plotPoints->100,DisplayFunction->None];
show[p5,p6,p7,p8,Boxed->False,Axes->None,ViewPoint->{1,-8,8},defaultFont->12.,ImageSize->700,Background->lightblue,DisplayFunction->$DisplayFunction];

See also Exercises 2.5 and 5.58 on the exponential of an antisymmetric matrix. In these exercises α is a real number and ((Subscript[a, 1]),(Subscript[a, 2]),(Subscript[a, 3])) is a unit vector in (R^3).

Clear["`*"]
Off[General::spell1]
co[x_,n_]:=Table[(Subscript[x, j]),{j,n}]
Unprotect[Power];
Format[Power[Subscript[x_,y_],z_]]:=DisplayForm[SuperscriptBox[SubscriptBox[x,y],z]]

angle[a_List]:=ArcCos[((-1+a[[1,1]]+a[[2,2]]+a[[3,3]])/2)]
ax[a_List]:=Simplify[((a-Transpose[a])/(2Sin[angle[a]]))]
axis[a_List]:={ax[a][[3,2]],-ax[a][[3,1]],ax[a][[2,1]]}

mat[a_,p_,n_]:=Table[Subscript[a,ToString[j]<>ToString[i]],{i,p},{j,n}];
MatrixForm[mat[a,3,3]]
angle[mat[a,3,3]]
axis[mat[a,3,3]]

Print["Antisymmetric matrix determined by ((Subscript[a, 1]),(Subscript[a, 2]),(Subscript[a, 3]))"]
r[{a1_,a2_,a3_}]:={{0,-a3,a2},{a3,0,-a1},{-a2,a1,0}};
R[an_,a_List]:=Cos[an]IdentityMatrix[3]+(1-Cos[an])Transpose[{a}].{a}+Sin[an]r[a];

av=co[a,3];
MatrixForm[r[av]]
Print["Matrix of rotation by angle α about axis ((Subscript[a, 1]),(Subscript[a, 2]),(Subscript[a, 3]))"]
MatrixForm[R[α,av]]

Print["Test of orthogonality"]
Simplify[Transpose[R[α,av]].R[α,av]==IdentityMatrix[3]]/.((av[[1]])^2)->1-((av[[2]])^2)-((av[[3]])^2)

Print["Exponential of α times antisymmetric matrix determined by ((Subscript[a, 1]),(Subscript[a, 2]),(Subscript[a, 3]))"]
MatrixForm[ComplexExpand[MatrixExp[α r[av]]]/.((av[[1]])^2)->1-((av[[2]])^2)-((av[[3]])^2)]
Print["Equality of two matrices"]
Simplify[ComplexExpand[MatrixExp[α r[av]]==R[α,av]]/.((av[[1]])^2)->1-((av[[2]])^2)-((av[[3]])^2)]

As a verification, we compute  the example from the exercise; next several orthogonal matrices of determinant 1 and their corresponding angles and axes of rotation; and finally some matrix exponentials.

Print["Matrix of rotation"]
(rot=R[(π/2),{1,0,0}].R[(π/2),{0,1,0}])//MatrixForm
MatrixForm[Transpose[rot].rot]
angle[rot]
(Sqrt[3])axis[rot]

Print["Matrix of rotation"]
(rot=Simplify[R[(π/3),{(Sqrt[(1/5)]),(Sqrt[(2/5)]),(Sqrt[(2/5)])}]])//MatrixForm
MatrixForm[Together[Transpose[rot].rot]]
angle[rot]
axis[rot]

Print["Matrix of rotation"]
(rot=Simplify[R[((2π)/3),{-(3/4),-(1/4),((Sqrt[6])/4)}]])//MatrixForm
MatrixForm[Together[Transpose[rot].rot]]
angle[rot]
axis[rot]

Print["Exponential of antisymmetric matrix"]
MatrixForm[MatrixExp[α {{0,0,0},{0,0,-1},{0,1,0}}]]

Print["Exponential of antisymmetric matrix"]
MatrixForm[MatrixExp[((2π)/3) {{0,-((Sqrt[6])/4),-(1/4)},{((Sqrt[6])/4),0,(3/4)},{(1/4),-(3/4),0}}]]
MatrixForm[Simplify[%-rot]]

Exercise 4.26   (Hopf fibration and stereographic projection)

Clear["`*"]
Off[General::spell]
Off[General::spell1]
na=3;
nb=40;
nu=500;
point=0.002;
viewx=-2;
viewy=-2;
viewz=0.7;
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
hopf[a_,b_,u_]:={Cos[a] Cos[u],Cos[a] Sin[u],Sin[a] Cos[(u+b)],Sin[a] Sin[(u+b)]}
sterproj[{x_,y_,z_,t_}]:={x/(1-t),y/(1-t),z/(1-t)}
list=Table[{darkblue,Point[sterproj[hopf[a,b,u]]]},{a,0,π,π/(2 na+1)},{b,0,2π,2 π/nb},{u,0,2π,2 π/nu}];
show[Graphics3D[{PointSize[point],list},Axes->False,AspectRatio->1,Boxed->False,ViewPoint->{viewx,viewy,viewz}],Background->lightblue,ImageSize->1100];

Exercise 4.27   (Steiner's Roman surface)

Clear["`*"]
Off[General::spell1]
lightblue=RGBColor[220/256,248/256,248/256];
αmin=0;
αmax=2π;
θmin=-π/2;
θmax=π/2;
nα=101;
nθ=37;
y1[α_,θ_]:=Cos[α]Cos[θ];
y2[α_,θ_]:=Sin[α]Cos[θ];
y3[α_,θ_]:=Sin[θ];
Ψ[y1_,y2_,y3_]:={y2 y3,y3 y1,y1 y2}
ϕ[α_,θ_]:=Ψ[y1[α,θ],y2[α,θ],y3[α,θ]]
parametricPlot3D[Append[ϕ[α,θ],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{α,αmin,αmax},{θ,θmin,θmax},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},Background->lightblue,plotPoints->{3nα,3nθ},ViewPoint->{1,2,2},PlotRange->{{-0.5,0.5},{-0.5,0.5},{-0.5,0.5}},Boxed->False,Ticks->None,Axes->None,ImageSize->1000];
parametricPlot3D[Append[ϕ[α,θ],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{α,αmin,αmax},{θ,θmin,θmax},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},Background->lightblue,plotPoints->{3nα,3nθ},ViewPoint->{1,2,2},PlotRange->{{-0.5,0.5},{-0.5,0.5},{-0.5,0.25}},Boxed->False,Ticks->None,Axes->None,ImageSize->1000];
parametricPlot3D[Append[ϕ[α,θ],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{α,αmin,αmax},{θ,θmin,θmax},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},Background->lightblue,plotPoints->{3nα,3nθ},ViewPoint->{1,2,2},PlotRange->{{-0.5,0.15},{-0.5,0.5},{-0.5,0.5}},Boxed->False,Ticks->None,Axes->None,ImageSize->1000];

The following is time-consuming.

Clear["`*"]
Off[General::spell1]
lightblue=RGBColor[220/256,248/256,248/256];
αmin=0;
αmax=2π;
θmin=-π/2;
θmax=π/2;
nα=101;
nθ=37;
y1[α_,θ_]:=Cos[α]Cos[θ];
y2[α_,θ_]:=Sin[α]Cos[θ];
y3[α_,θ_]:=Sin[θ];
Ψ[y1_,y2_,y3_]:={y2 y3,y3 y1,y1 y2}
ϕ[α_,θ_]:=Ψ[y1[α,θ],y2[α,θ],y3[α,θ]]
p[n_]:=parametricPlot3D[Append[ϕ[α,θ],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{α,αmin,αmax},{θ,θmin,θmax},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},Background->lightblue,plotPoints->{3nα,3nθ},ViewPoint->{1,2,2},PlotRange->{{-0.5,0.5},{-0.5,0.5},{-0.5,-0.5+n/12 0.5}},Boxed->False,Ticks->None,Axes->None,ImageSize->1000,DisplayFunction->None];
(*SetOptions[SelectedNotebook[],AnimationDisplayTime->.2]; *)       
(*SetOptions[SelectedNotebook[],CellGrouping->Automatic]; 
movie:=Table[Show[p[n],ImageSize->1000],{n,0,24}];   *)                  
ListAnimate[Table[Show[p[n],ImageSize->600],{n,0,24}]]                                                                                                        
(*SelectionMove[SelectedNotebook[],All,GeneratedCell];
FrontEndExecute[FrontEndToken["OpenCloseGroup"]];*)

Exercise 4.28   (Cayley's surface)

Clear["`*"]
Off[General::spell]
Off[General::spell1]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];

x1min=-0.5;
x1max=2.5;
x2max=1.5;
x2min=-x2max;
x2maxc=Min[x1max,Sqrt[x1max/3]];
x2minc=-x2maxc;
planex2=6;
planex3=-6;
viewx1=1;
viewx2=-3;
viewx3=2.5;
raster=0.05;
point=0.001;
dash=0.01;

f[x1_,x2_]:=x2^3-x1 x2
h[x2_]:=3x2^2
list1=Table[{darkblue,Point[{x1,x2,f[x1,x2]}]},{x1,x1min,x1max,raster},{x2,x2min,x2max,raster}];
list2=Table[{darkblue,Point[{x1,x2,planex3}]},{x1,x1min,x1max,raster},{x2,x2min,x2max,raster}];
list3=Table[{darkblue,Point[{x1,planex2,f[x1,x2]}]},{x1,x1min,x1max,raster},{x2,x2min,x2max,raster}];
cloud=Graphics3D[{PointSize[point],list1,list2,list3},Axes->False,PlotRange->All,AspectRatio->1,Boxed->False,ViewPoint->{viewx1,viewx2,viewx3},DisplayFunction->Identity];
x1boundaries=ParametricPlot3D[{{x1,x2min,f[x1,x2min]},{x1,x2max,f[x1,x2max]},{x1,x2min,planex3},{x1,x2max,planex3},{x1,planex2,f[x1,x2min]},{x1,planex2,f[x1,x2max]}},{x1,x1min,x1max},Axes->False,PlotRange->All,AspectRatio->1,ViewPoint->{viewx1,viewx2,viewx3},Boxed->False,DisplayFunction->Identity];
x2boundaries=ParametricPlot3D[{{x1min,x2,f[x1min,x2]},{x1max,x2,f[x1max,x2]},{x1min,x2,planex3},{x1max,x2,planex3},{x1min,planex2,f[x1min,x2]},{x1max,planex2,f[x1max,x2]}},{x2,x2min,x2max},Axes->False,PlotRange->All,ViewPoint->{viewx1,viewx2,viewx3},AspectRatio->1,Boxed->False,DisplayFunction->Identity];
crit=parametricPlot3D[{{h[x2],x2,f[h[x2],x2]},{h[x2],x2,planex3},{h[x2],planex2,f[h[x2],x2]}},{x2,x2minc,x2maxc},Axes->False,ViewPoint->{viewx1,viewx2,viewx3},PlotRange->All,AspectRatio->1,Boxed->False,DisplayFunction->None];
planes=Graphics3D[{Dashing[{dash,dash}],Line[{{x1min,x2min,planex3},{x1min,planex2,planex3}}],Line[{{x1max,x2min,planex3},{x1max,planex2,planex3}}],Line[{{x1min,planex2,planex3},{x1min,planex2,f[x1min,x2min]}}],Line[{{x1max,planex2,planex3},{x1max,planex2,f[x1max,x2min]}}],Line[{{x1min,planex2,planex3},{x1max,planex2,planex3}}]},Axes->False,ViewPoint->{viewx1,viewx2,viewx3},PlotRange->All,AspectRatio->1,Boxed->False,DisplayFunction->None];
show[cloud,x1boundaries,x2boundaries,crit,planes,(*BaseStyle->RGBColor[1,0,0],*)Background->lightblue,ImageSize->800,DisplayFunction->$DisplayFunction];

Print["Part (i)"]
Print["g is submersive, as follows from"]
g[{x1_,x2_,x3_}]:=x2^3-x1 x2-x3
Flatten[Solve[{{(∂_(Subscript[x, 1]))g[{(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])}],(∂_(Subscript[x, 2]))g[{(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])}],(∂_(Subscript[x, 3]))g[{(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])}]}=={0,0,0}},{(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])}]]

Print["Part (ii)"]
φ[{y1_,y2_,y3_}]:={y1,y2,y2^3-y1 y2}
Composition[g,φ][{y1,y2,y3}]
Flatten[Solve[g[{(Subscript[y, 1]),(Subscript[y, 2]),(Subscript[y, 3])}]==0,(Subscript[y, 3])]]/.{Rule->Equal}

Print["Part (iii)"]
ππ[{x1_,x2_,x3_}]:={x1,0,x3}
Ξ=Composition[ππ,φ];
Ξ[{(Subscript[x, 1]),(Subscript[x, 2]),0}]
(∂_(Subscript[x, 1]))Ξ[{(Subscript[x, 1]),(Subscript[x, 2]),0}]=={0,0,0}
(∂_(Subscript[x, 2]))Ξ[{(Subscript[x, 1]),(Subscript[x, 2]),0}]=={0,0,0}

Print["Part (iv)"]
Simplify[Eliminate[Ξ[{3(Subscript[x, 2])^2,(Subscript[x, 2]),0}]=={(Subscript[y, 1]),0,(Subscript[y, 3])},(Subscript[x, 2])]]

Print["Part (v)"]
h[x1_,x3_]:=4x1^3-27x3^2
First[Solve[{{(∂_(Subscript[x, 1]))h[(Subscript[x, 1]),(Subscript[x, 3])],(∂_(Subscript[x, 3]))h[(Subscript[x, 1]),(Subscript[x, 3])]}=={0,0}},{(Subscript[x, 1]),(Subscript[x, 3])}]]/.{Rule->Equal}

Exercise 4.29   (Whitney's umbrella)

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];

parametricPlot3D[Append[{y1 y2,y1,y2 y2},SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{y1,-1,1},{y2,-1,1},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},AxesStyle->RGBColor[0,0.5,0],Background->lightblue,plotPoints->{51,55},DisplayFunction->None];
Graphics3D[{Text["x1",{1.2,0,0}],Text["x2",{0,1.2,0}],Text["x3",{0,0,1.3}],{AbsoluteThickness[.75],RGBColor[0,0.5,0],Line[{{-2,0,0},{1.5,0,0}}]},{AbsoluteThickness[.75],RGBColor[0,0.5,0],Line[{{0,-1.5,0},{0,1.5,0}}],{AbsoluteThickness[2.1],RGBColor[0,0.5,0],Line[{{0,0,-1.8},{0,0,2}}]}}}];
show[%%,%,Axes->False,PlotRange->All,Ticks->None,Boxed->False,ViewPoint->{20,10,12},defaultFont->12.,ImageSize->600,DisplayFunction->$DisplayFunction];

CHAPTER 5: EXERCISES

Exercise 5.1

Clear["`*"]
co[x_,n_]:=Table[Subscript[x,j],{j,n}]
xv=co[x,2];
hv=co[h,2];
Print["Equation for point ((Subscript[h, 1,])(Subscript[h, 2])) belonging to geometric tangent space"] 
g[{x1_,x2_}]:=3x1^2+24x1-x2^2+36
Simplify[{(∂_(Subscript[x, 1]))g[xv],(∂_(Subscript[x, 2])) g[xv]}.hv=={(∂_(Subscript[x, 1]))g[xv],(∂_(Subscript[x, 2])) g[xv]}.xv]
(3(Subscript[x, 1])+12)(Subscript[h, 1])-(Subscript[x, 2])(Subscript[h, 2])==3(Subscript[x, 1])^2+12(Subscript[x, 1])-(Subscript[x, 2])^2
Simplify[%,%%]

Print["Parametric representation of geometric tangent space, with λ ϵ ℝ"] 
phi[t_]:={-4+2Cosh[t],2Sqrt[3]Sinh[t]}
phi[t]+λ(∂_t) phi[t]

Exercise 5.2

Clear["`*"]
Off[Eliminate::ifun]
lightblue=RGBColor[220/256,248/256,248/256];
ϕ[a_,b_,c_][y1_,y2_]:={a Sinh[y1]Cos[y2],b Sinh[y1]Sin[y2],c Cosh[y1]}
p1=parametricPlot3D[Append[ϕ[3,2,2][y1,y2],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{y1,0,2},{y2,-π,π},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{2{0,2,2},RGBColor[0,1,1]}},plotPoints->{81,81},DisplayFunction->None];
p2=parametricPlot3D[Append[ϕ[3,2,-2][y1,y2],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{y1,0,2},{y2,-π,π},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},plotPoints->{81,81},DisplayFunction->None];
show[p1,p2,PlotRange->All,Axes->False,Boxed->False,ViewPoint->{2,1,0.7},Background->lightblue,ImageSize->800,DisplayFunction->$DisplayFunction];

Print["Equation for hyperboloid of two-sheets"] 
fullSimplify[Eliminate[ϕ[a,b,c][y1,y2]=={(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])},{y1,y2}]]
g[x1_,x2_,x3_]:=-x1^2/a^2-x2^2/b^2+x3^2/c^2-1
Simplify[a^2b^2c^2g[(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])]==0]
g[(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])]
Print["Equation for point ((Subscript[h, 1,])(Subscript[h, 2]),(Subscript[h, 3])) belonging to geometric tangent space"] 
fullSimplify[{(∂_(Subscript[x, 1])) g[(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])],(∂_(Subscript[x, 2])) g[(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])],(∂_(Subscript[x, 3])) g[(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])]}.({(Subscript[h, 1]),(Subscript[h, 2]),(Subscript[h, 3])}-{(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])})==0]
Print["Parametrization of hyperboloid of two-sheets"] 
ϕ[a,b,c][(Subscript[y, 1]),(Subscript[y, 2])]
Print["Parametric representation of geometric tangent space, with λ and μ ϵ ℝ"] 
{h1,h2,h3}=ϕ[a,b,c][(Subscript[y, 1]),(Subscript[y, 2])]+λ(∂_(Subscript[y, 1]))ϕ[a,b,c][(Subscript[y, 1]),(Subscript[y, 2])]+μ(∂_(Subscript[y, 2]))ϕ[a,b,c][(Subscript[y, 1]),(Subscript[y, 2])]
Print["Representation of hyperboloid of two-sheets as union of two graphs"] 
sol=Solve[g[x1,x2,x3]==0,x3];
f1[x1_,x2_]=x3/.sol[[2]];
f2[x1_,x2_]=x3/.sol[[1]];
f1[(Subscript[x, 1]),(Subscript[x, 2])]
f2[(Subscript[x, 1]),(Subscript[x, 2])]
Print["Parametric representation of geometric tangent space, with λ and μ ϵ ℝ"] 
fullSimplify[{(Subscript[x, 1]),(Subscript[x, 2]),f1[(Subscript[x, 1]),(Subscript[x, 2])]}+λ{1,0,(∂_(Subscript[x, 1]))f1[(Subscript[x, 1]),(Subscript[x, 2])]}+μ{0,1,(∂_(Subscript[x, 2]))f1[(Subscript[x, 1]),(Subscript[x, 2])]}]
fullSimplify[{(Subscript[x, 1]),(Subscript[x, 2]),f2[(Subscript[x, 1]),(Subscript[x, 2])]}+λ{1,0,(∂_(Subscript[x, 1]))f2[(Subscript[x, 1]),(Subscript[x, 2])]}+μ{0,1,(∂_(Subscript[x, 2]))f2[(Subscript[x, 1]),(Subscript[x, 2])]}]
Print["Verification"] 
fullSimplify[{(∂_(Subscript[x, 1])) g[(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])],(∂_(Subscript[x, 2])) g[(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])],(∂_(Subscript[x, 3])) g[(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])]}.({h1,h2,h3}-{(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])})/.Thread[{(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])}->ϕ[a,b,c][(Subscript[y, 1]),(Subscript[y, 2])]]]

Exercise 5.3

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
Phi[{x1_,x2_}]:={a/b x2,-b/a x1}
Nest[Phi,{(Subscript[x, 1]),(Subscript[x, 2])},4]
t=3 π/4;
a=2;
b=1;
x1=a Cos[t];
x2=b Sin[t];
p={x1,x2};
q={a/b x2,-b/a x1};
p1=Graphics[{Text["p+",p],Text["p-",-p],Text["q+",q],Text["q-",-q],{AbsolutePointSize[5],darkblue,Point[p],Point[-p],Point[q],Point[-q]},{RGBColor[1,0,0],Circle[{0,0},{a,b}]}},AspectRatio->Automatic];
p2=Graphics[{darkblue,{Line[{{x1-a Sin[t],x2+b Cos[t]},{x1+a Sin[t],x2-b Cos[t]}}]},Line[{{-x1-a Sin[t],-x2+b Cos[t]},{-x1+a Sin[t],-x2-b Cos[t]}}],Line[{{a/b x2-a Sin[t+π/2],-b/a x1+b Cos[t+π/2]},{a/b x2+a Sin[t+π/2],-b/a x1-b Cos[t+π/2]}}],Line[{{-a/b x2-a Sin[t+π/2],b/a x1+b Cos[t+π/2]},{-a/b x2+a Sin[t+π/2],b/a x1-b Cos[t+π/2]}}]}];
show[p1,p2,defaultFont->12.,Background->lightblue,ImageSize->600];

Exercise 5.6

See the file Ex5.6.pdf

Exercise 5.11

Missing. PV409

Exercise 5.18   (Lemniscate)

Clear["`*"]
Off[General::spell1]
lightblue=RGBColor[220/256,248/256,248/256];
c={1/Sqrt[2],0};
norm[x_]:=Sqrt[x[[1]]^2+x[[2]]^2]
Print["Part (i)"]
Expand[norm[({(Subscript[x, 1]),(Subscript[x, 2])}-c)]^2norm[({(Subscript[x, 1]),(Subscript[x, 2])}+c)]^2-norm[c]^4]
g[x1_,x2_]:=norm[{x1,x2}]^4-x1^2+x2^2
Simplify[%%==g[(Subscript[x, 1]),(Subscript[x, 2])]]
Print["Part (ii)"]
Flatten[Solve[{{(∂_(Subscript[x, 1])) g[(Subscript[x, 1]),(Subscript[x, 2])],(∂_(Subscript[x, 2])) g[(Subscript[x, 1]),(Subscript[x, 2])]}=={0,0},g[(Subscript[x, 1]),(Subscript[x, 2])]==0},{(Subscript[x, 1]),(Subscript[x, 2])}]]/.{Rule->Equal}
Print["Part (iii)"]
fullSimplify[g[x1,x2]==0/.Thread[{x1,x2}->r{ Cos[α], Sin[α]}],r>0]
Print["Part (iv)"]
sol[r_]=fullSimplify[Solve[{g[(Subscript[x, 1]),(Subscript[x, 2])]==0,(Subscript[x, 1])^2-(Subscript[x, 2])^2==r^4},{(Subscript[x, 1]),(Subscript[x, 2])}],r>0];
Part[sol[r],{-2,-1}]/.{Rule->Equal}
(SubPlus[ϕ])[r_]:={(Subscript[x, 1]),(Subscript[x, 2])}/.sol[r][[-1]]
(SubPlus[ϕ])[r]
(SubMinus[ϕ])[r_]:={(Subscript[x, 1]),(Subscript[x, 2])}/.sol[r][[-2]]
(SubMinus[ϕ])[r]
ArcCos[(∂_r) (SubPlus[ϕ])[r].(∂_r) (SubMinus[ϕ])[r]/(norm[(∂_r) (SubPlus[ϕ])[r]]norm[(∂_r) (SubMinus[ϕ])[r]])/.r->0]
parametricPlot[Evaluate[{(SubPlus[ϕ])[r],(SubMinus[ϕ])[r]}],{r,-1,1},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],PlotPoints->200,Ticks->None,AspectRatio->Automatic,Background->lightblue,ImageSize->800];

Exercises 5.19   (Astroid)   and 5.20   (Cissoid)

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
p1=parametricPlot[{Cos[t]^3,Sin[t]^3},{t,-π,π},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],plotPoints->200,AspectRatio->Automatic,Ticks->None,PlotRange->{{-1.5,1.5},{-1.5,1.5}},DisplayFunction->None];
p2=parametricPlot[{{1-y,Sqrt[((1-y)^3)/(1+y)]},{1-y,-Sqrt[((1-y)^3)/(1+y)]}},{y,-0.8,1},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],plotPoints->200,PlotRange->{{-1,3},{-5.5,5.5}},Ticks->None,AspectRatio->Automatic,DisplayFunction->None];
p3=parametricPlot[{{1-y,Sqrt[((1-y)^3)/(1+y)]},{1-y,-Sqrt[((1-y)^3)/(1+y)]}},{y,-0.2385,1},PlotStyle->RGBColor[1,0,0],plotPoints->100,PlotRange->{{-1,3},Automatic},AspectRatio->Automatic,Ticks->{{0,1},{1}},PlotStyle->AbsoluteThickness[1.5],DisplayFunction->None];
p4=Graphics[{{AbsoluteThickness[2],RGBColor[1,0,0],Circle[{1,0},1,{-0.5 π,0.5 π}]},{Dashing[{0.025,0.025}],RGBColor[1,0,0],Circle[{1,0},1]},{Dashing[{0.045,0.045}],darkblue,Line[{{2,5.5},{2,-5.5}}]}}];
p5=show[p2,p3,p4,PlotRange->{{-1,2.5},{-3,3}},AspectRatio->Automatic,DisplayFunction->None];
show[GraphicsGrid[{{p1,p5}}],Background->lightblue,ImageSize->1000,DisplayFunction->$DisplayFunction];

Exercise 5.21   (Conchoid and trisection of angle)

Clear["`*"]
Off[plot::plnr]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
d=0.4;
p1=Graphics[{Text["0",{-0.1,-0.6}],Text["A",{1.2,1}],{Dashing[{0.025,0.025}],darkblue,Line[{{1,-10},{1,10}}]},{Dashing[{0.02,0.02}],darkblue,Line[{{0,0},{1.5,2.25}}]},{AbsolutePointSize[4],darkblue,Point[{1,1.5}],Point[{0.77812,1.16718}],Point[{1.22188,1.83282}]}}];
p2=plot[{Sqrt[(-x^4+2 x^3+(d^2-1) x^2)/(x^2-2 x+1)],-Sqrt[(-x^4+2 x^3+(d d-1) x^2)/(x^2-2 x+1)]},{x,d,1+d},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],AxesOrigin->{0,0},Axes->True,Ticks->None,plotPoints->50,PlotRange->{{-0.25,2},{-5,5}},DisplayFunction->None];
p3=show[p2,p1,AspectRatio->1,defaultFont->12.,DisplayFunction->None];
conchoid[d_][s_]:=(-d+Cosh[s])/(Cosh[s]){1,Sinh[s]}
p4=parametricPlot[Evaluate[Table[conchoid[d][s],{d,1/2,3/2,1/10}]],{s,-1.5,1.5},PlotStyle->RGBColor[1,0,0],AspectRatio->Automatic,Axes->None,plotPoints->100,PlotRange->{{-0.6,0.6},Automatic},DisplayFunction->None];
show[GraphicsGrid[{{p3,p4}}],Background->lightblue,ImageSize->1000,DisplayFunction->$DisplayFunction];

Exercise 5.22   (Villarceau's circles)

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
parametricPlot3D[{Cos[t] (2+Cos[u]),Sin[t] (2+Cos[u]),Sin[u]},{t,-π,π},{u,-π,π},plotPoints->50,Axes->False,Boxed->False,AspectRatio->Automatic,DisplayFunction->None];
Graphics[{{AbsoluteThickness[1],darkblue,Circle[{2,0},1],Circle[{-2,0},1],Circle[{0,-5},3],Circle[{0,-5},1]},{darkblue,AbsoluteThickness[0.5],Line[{{-2,1},{2,1}}],Line[{{-2,-1},{2,-1}}]},{darkblue,AbsolutePointSize[5],Point[{1.5,0.5 Sqrt[3]}],Point[{-1.5,-0.5 Sqrt[3]}],Point[{1.5,-5}]},{AbsolutePointSize[5],GrayLevel[0.25],Point[{-1.5,-5}]},{darkblue,AbsoluteThickness[0.5],Line[{{-3.5,-3.5/Sqrt[3]},{3,3/Sqrt[3]}}]},{darkblue,AbsoluteThickness[1.5],Circle[{0,-6},{Sqrt[3],2},{-0.5 π,0.5 π}],Circle[{0,-4},{Sqrt[3],2},{-0.5 π,0.5 π}]},{darkblue,AbsoluteThickness[1.5],Dashing[{0.02,0.02}],Circle[{0,-6},{Sqrt[3],2},{0.5 π,1.5 π}],Circle[{0,-4},{Sqrt[3],2},{0.5 π,1.5 π}]},{RGBColor[1,0,0],AbsoluteThickness[0.5],Dashing[{0.015,0.015}],Line[{{3,0},{3,-5}}],Line[{{-3,0},{-3,-5}}],Line[{{1,0},{1,-5}}],Line[{{-1,0},{-1,-5}}],Line[{{1.5,0.5 Sqrt[3]},{1.5,-5}}],Line[{{-1.5,-0.5 Sqrt[3]},{-1.5,-5}}]},Text["T",{-3,1}],Text["V",{3,2}],Text["-q",{-2,-5}],Text["q",{2,-5}]},{AspectRatio->Automatic,defaultFont->12.//Evaluate}];
show[GraphicsGrid[{{%%,%}}],Background->lightblue,ImageSize->1000,DisplayFunction->$DisplayFunction];

Exercise 5.23   (Torus sections)

Missing. PV426N

Exercise 5.26   (Cauchy-Schwarz inequality in (R^n), Grassmann's, Jacobi's and Lagrange's identities in (R^3))

Clear["`*"]
vec[v_]:=Table[(Subscript[v, j]),{j,3}]
v1=vec[(Subscript[v, 1])];
v2=vec[(Subscript[v, 2])];
v3=vec[(Subscript[v, 3])];
v4=vec[(Subscript[v, 4])];

Print["Part (ii)"]
Simplify[Cross[v1,Cross[v2,v3]]]
Simplify[Cross[v1,Cross[v2,v3]]==v3.v1 v2-v1.v2 v3]

Print["Part (iii)"]
Cross[v1,Cross[v2,v3]]+Cross[v2,Cross[v3,v1]]+Cross[v3,Cross[v1,v2]]

Print["Part (iv)"]
Cross[Cross[v1,v2],Cross[v2,v3]]
Det[{v4,v1,v2}]v3-Det[{v1,v2,v3}]v4
Simplify[Cross[Cross[v1,v2],Cross[v3,v4]]==Det[{v4,v1,v2}]v3-Det[{v1,v2,v3}]v4] 

Cross[v1,v2].Cross[v3,v4]
Det[{{v1.v3,v1.v4},{v2.v3,v2.v4}}]
Simplify[Cross[v1,v2].Cross[v3,v4]==Det[{{v1.v3,v1.v4},{v2.v3,v2.v4}}]]

Exercise 5.27  (Spherical trigonometry)

The code below might be improved. Formulae have been added by means of Xfig.

Clear["`*"];
Off[General::spell]
Off[General::spell1]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];

(* transparant sphere *)
x1[a_,t_]:=Cos[a]*Cos[t];
x2[a_,t_]:=Sin[a]*Cos[t];
x3[a_,t_]:=Sin[t];
x[a_,t_]:={x1[a,t],x2[a,t],x3[a,t]};

raster=0.075;
point=0.001;
list=Table[Point[x[a,t]],{a,-π,π,raster},{t,-π/2,π/2,raster}];
S=Graphics3D[{PointSize[point],list},Axes->False,PlotRange->All,AspectRatio->1,Boxed->False];

(* three points axis A,B,C on unit sphere *)

A=x[π/3,π/3];
A1=A[[1]];
A2=A[[2]];
A3=A[[3]];

B=x[-π/10,π/10];
B1=B[[1]];
B2=B[[2]];
B3=B[[3]];

CC=x[π/3,-π/7];
CC1=CC[[1]];
CC2=CC[[2]];
CC3=CC[[3]];

norm[a1_,a2_,a3_]:=N[Sqrt[(a1)^2+(a2)^2+(a3)^2]];

(* matrix of rotation about axis {a1,a2,a3} by angle a *)
R[a_,a1_,a2_,a3_]:={{Cos[a]+a1^2(1-Cos[a]),-a3*Sin[a]+a1*a2*(1-Cos[a]),a2*Sin[a]+a1*a3*(1-Cos[a])},{a3*Sin[a]+a1*a2*(1-Cos[a]),Cos[a]+a2^2(1-Cos[a]),-a1*Sin[a]+a2*a3*(1-Cos[a])},{-a2*Sin[a]+a1*a3*(1-Cos[a]),a1*Sin[a]+a2*a3*(1-Cos[a]),Cos[a]+a3^2(1-Cos[a])}};

(* vector r on unit sphere perpendicular to p and q, that is, normalized cross product of p and q *)
Crossproduct[p1_,p2_,p3_,q1_,q2_,q3_]:={p1,p2,p3}\[Cross]{q1,q2,q3};
rr1[p1_,p2_,p3_,q1_,q2_,q3_]:=Crossproduct[p1,p2,p3,q1,q2,q3][[1]];
rr2[p1_,p2_,p3_,q1_,q2_,q3_]:=Crossproduct[p1,p2,p3,q1,q2,q3][[2]];
rr3[p1_,p2_,p3_,q1_,q2_,q3_]:=Crossproduct[p1,p2,p3,q1,q2,q3][[3]];
Nnorm[p1_,p2_,p3_,q1_,q2_,q3_]:=norm[rr1[p1,p2,p3,q1,q2,q3],rr2[p1,p2,p3,q1,q2,q3],rr3[p1,p2,p3,q1,q2,q3]];
r1[p1_,p2_,p3_,q1_,q2_,q3_]:=rr1[p1,p2,p3,q1,q2,q3]/Nnorm[p1,p2,p3,q1,q2,q3];
r2[p1_,p2_,p3_,q1_,q2_,q3_]:=rr2[p1,p2,p3,q1,q2,q3]/Nnorm[p1,p2,p3,q1,q2,q3];
r3[p1_,p2_,p3_,q1_,q2_,q3_]:=rr3[p1,p2,p3,q1,q2,q3]/Nnorm[p1,p2,p3,q1,q2,q3];

(* as a control, norm of perpendicular vector R and inproduct of R and A *)
N[norm[r1[A1,A2,A3,B1,B2,B3],r2[A1,A2,A3,B1,B2,B3],r3[A1,A2,A3,B1,B2,B3]]];
N[{A1,A2,A3}.{r1[A1,A2,A3,B1,B2,B3],r2[A1,A2,A3,B1,B2,B3],r3[A1,A2,A3,B1,B2,B3]}];

(* geodesic connecting p and q arising as image under rotation about r *)
geod[s_,p1_,p2_,p3_,q1_,q2_,q3_]:=R[s,r1[p1,p2,p3,q1,q2,q3],r2[p1,p2,p3,q1,q2,q3],r3[p1,p2,p3,q1,q2,q3]].{p1,p2,p3};
angle[p1_,p2_,p3_,q1_,q2_,q3_]:=ArcCos[{p1,p2,p3}.{q1,q2,q3}];

(* as a check,the geodesic must start at p and end at q *)
N[geod[0,A1,A2,A3,B1,B2,B3]];
N[geod[angle[A1,A2,A3,B1,B2,B3],A1,A2,A3,B1,B2,B3]];

(* graphics of the geodesic *)
GEOD[p1_,p2_,p3_,q1_,q2_,q3_]:=parametricPlot3D[Evaluate[geod[s,p1,p2,p3,q1,q2,q3]],{s,0,angle[p1,p2,p3,q1,q2,q3]},plotPoints->200,DisplayFunction->None];

GEOAB=GEOD[A1,A2,A3,B1,B2,B3];
GEOBC=GEOD[B1,B2,B3,CC1,CC2,CC3];
GEOCA=GEOD[CC1,CC2,CC3,A1,A2,A3];

dash=0.007;
thick=0.002;
LA=Graphics3D[{Thickness[thick],Dashing[{dash,2dash}],Line[{{0,0,0},{A1,A2,A3}}]},DisplayFunction->None];
LB=Graphics3D[{Thickness[thick],Dashing[{dash,2dash}],Line[{{0,0,0},{B1,B2,B3}}]},DisplayFunction->None];
LC=Graphics3D[{Thickness[thick],Dashing[{dash,2dash}],Line[{{0,0,0},{CC1,CC2,CC3}}]},DisplayFunction->None];

(* unit tangent vector of geodesic connecting p and q at p *)
tang[s_,p1_,p2_,p3_,q1_,q2_,q3_]:=(s/Nnorm[p1,p2,p3,q1,q2,q3])*({q1,q2,q3}-{p1,p2,p3}.{q1,q2,q3} {p1,p2,p3});

TA[p1_,p2_,p3_,q1_,q2_,q3_]:=parametricPlot3D[Evaluate[{p1,p2,p3}+tang[s,p1,p2,p3,q1,q2,q3]],{s,0,0.6},plotPoints->200,DisplayFunction->None];

TAAB=TA[A1,A2,A3,B1,B2,B3];
TABA=TA[B1,B2,B3,A1,A2,A3];
TABC=TA[B1,B2,B3,CC1,CC2,CC3];
TACB=TA[CC1,CC2,CC3,B1,B2,B3];
TACA=TA[CC1,CC2,CC3,A1,A2,A3];
TAAC=TA[A1,A2,A3,CC1,CC2,CC3];

(* angles between tangent lines *)
(* N[ArcCos[tang[1,A1,A2,A3,B1,B2,B3].tang[1,A1,A2,A3,CC1,CC2,CC3]]/π]; *)
(* N[ArcCos[tang[1,B1,B2,B3,A1,A2,A3].tang[1,B1,B2,B3,CC1,CC2,CC3]]/π]; *)
(* N[ArcCos[tang[1,CC1,CC2,CC3,A1,A2,A3].tang[1,CC1,CC2,CC3,B1,B2,B3]]/π]; *)

ANGA=parametricPlot3D[Evaluate[{A1,A2,A3}+(Cos[a]/2)*tang[1,A1,A2,A3,B1,B2,B3]+(Sin[a]/2)*tang[1,A1,A2,A3,CC1,CC2,CC3]],{a,0,π/2},plotPoints->200,DisplayFunction->None];
ANGB=parametricPlot3D[Evaluate[{B1,B2,B3}+(Cos[a]/2)*tang[1,B1,B2,B3,A1,A2,A3]+(Sin[a]/2)*tang[1,B1,B2,B3,CC1,CC2,CC3]],{a,0,π/2},plotPoints->200,DisplayFunction->None];
ANGC=parametricPlot3D[Evaluate[{CC1,CC2,CC3}+(Cos[a]/2)*tang[1,CC1,CC2,CC3,A1,A2,A3]+(Sin[a]/2)*tang[1,CC1,CC2,CC3,B1,B2,B3]],{a,0,1.558},plotPoints->200,DisplayFunction->None];

(* final result:plot of three geodesics and six tangent lines on transparent sphere and the angles between the tangent lines *)
f=10;
view=f{A1+B1+CC1,A2+B2+CC2,A3+B3+CC3+1/8}/norm[A1+B1+CC1,A2+B2+CC2,A3+B3+CC3+1/8];
show[GEOAB,GEOBC,GEOCA,S,LA,LB,LC,TAAB,TABA,TABC,TACB,TACA,TAAC,ANGA,ANGB,ANGC,Axes->False,PlotRange->All,AspectRatio->1,Boxed->False,ViewPoint->view,ImageSize->900,BaseStyle->darkblue,Background->lightblue,DisplayFunction->$DisplayFunction];

Angle between two planes equals angle between normals

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
(*<<LinearAlgebra`Orthogonalization`*)
a1={1,0,0};
a2={0,1,0};
a3=(1/(Sqrt[3])){1,-1,-1};
a4=Normalize[a1-(Sqrt[3])a3];
a5=Normalize[Cross[a1,a2]];
a6=Normalize[Cross[a1,a4]];
a4.a1
a4.a2
a5.a6
thick=0.003;
l1=Graphics3D[{Thickness[thick],RGBColor[1,0,0],Line[{{0,0,0},a2}]}];
l2=Graphics3D[{Thickness[thick],RGBColor[1,0,0],Line[{{0,0,0},a4}]}];
l3=Graphics3D[{Thickness[thick],RGBColor[1,0,0],Line[{{0,0,0},a5}]}];
l4=Graphics3D[{Thickness[thick],RGBColor[1,0,0],Line[{{0,0,0},a6}]}];
pl1=parametricPlot3D[Append[λ a1+μ a2,SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{λ,-1,1},{μ,-0.3,1},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},plotPoints->40,DisplayFunction->None];
pl2=parametricPlot3D[Append[λ a1+μ a4,SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{λ,0,1},{μ,-0.3,1},plotPoints->40,lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},DisplayFunction->None];
show[l1,l2,l3,l4,pl1,pl2,ViewPoint->5{-2,-1,0.5},Boxed->False,Axes->None,Background->lightblue,ImageSize->800,DisplayFunction->$DisplayFunction];

Exercise 5.29  (Stereographic projection)

Clear["`*"];
Off[General::spell1]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];

x1[a_,t_]:=Cos[a]Cos[t];
x2[a_,t_]:=Sin[a]Cos[t];
x3[a_,t_]:=Sin[t];
x[a_,t_]:={x1[a,t],x2[a,t],1+x3[a,t]};

y1[a_,t_]:=2Cos[a]Cos[t]/(1-Sin[t]);
y2[a_,t_]:=2Sin[a]Cos[t]/(1-Sin[t]);
y[a_,t_]:={y1[a,t],y2[a,t],0};

(* 
p1=parametricPlot3D[Evaluate[x[a,t]],{a,-π,π},{t,-π/2+0.01,π/2-0.01},plotPoints->30,DisplayFunction->None];
p2=parametricPlot3D[Evaluate[y[a,t]],{a,-π,π},{t,-π/2+0.01,π/2-0.01},plotPoints->30,DisplayFunction->None];
l1=Graphics3D[{Thickness[0.003],Line[{x[π/4,π/3],y[π/4,π/3]}]},Shading->False];
l2=Graphics3D[{Thickness[0.003],Line[{x[-π/6,π/6],y[-π/6,π/6]}]},Shading->False]; 
show[p1,p2,l1,l2,ViewPoint->{3,1,0.5},Axes->None,Ticks->False,Boxed->False,Shading->False,DisplayFunction->$DisplayFunction]; 
*)

raster=0.075;
point=0.001;
list1=Table[Point[x[a,t]],{a,-π,π,raster},{t,-π/2+0.01,π/2-0.01,raster}];
sphere=Graphics3D[{PointSize[point],list1},Axes->False,PlotRange->All,AspectRatio->1,Boxed->False,DisplayFunction->None];

para=0.9;
circ[b_]:={para,Sqrt[1-para^2]*Cos[b],1+Sqrt[1-para^2]*Sin[b]};
circ1=parametricPlot3D[Evaluate[circ[b]],{b,-π,π},Axes->False,PlotRange->All,AspectRatio->1,Boxed->False,DisplayFunction->None];

proj[b_]:={2*para/(1-Sqrt[1-para^2]*Sin[b]),2*Sqrt[1-para^2]*Cos[b]/(1-Sqrt[1-para^2]*Sin[b]),0};
circ2=parametricPlot3D[Evaluate[proj[b]],{b,-π,π},Axes->False,AspectRatio->1,Boxed->False,DisplayFunction->None];

dash=0.007;
l1=Graphics3D[{RGBColor[1,0,0],Thickness[0.001],Dashing[{dash,dash}],Line[{{0,0,2},proj[π/2]}],Line[{{0,0,2},proj[0.9π]}],Line[{{0,0,2},proj[π/5]}],Line[{{0,0,2},proj[-π/2]}]}];
l2=Graphics3D[{Thickness[0.001],Line[{{0,0,0},1.1proj[π/2]}]}];
point=0.007;
p=Graphics3D[{PointSize[point],Point[circ[π/2]],Point[circ[0.9π]],Point[circ[π/5]],Point[circ[-π/2]],Point[proj[π/2]],Point[proj[0.9π]],Point[proj[π/5]],Point[proj[-π/2]]}];
mer=parametricPlot3D[Evaluate[x[0,t]],{t,-π/2,π/2},Axes->False,PlotRange->All,AspectRatio->1,Boxed->False,DisplayFunction->None];

show[circ1,circ2,sphere,mer,l1,l2,p,ViewPoint->{3,1.5,1.5},ImageSize->900,Background->lightblue,BaseStyle->darkblue,DisplayFunction->$DisplayFunction];

Exercise 5.31  (Mercator projection of sphere onto cylinder)

Clear["`*"]
Off[General::spell1]
<<WorldPlot`;
worldmap=WorldPlot[{World,RandomColors},WorldProjection->Mercator,WorldPoints->2000,WorldRange->{{-60,82.5},{-180,105}},WorldBackground->GrayLevel[0.96],WorldGrid->{7.5,7.5},DisplayFunction->Identity];

(* geographical coordinates Los Angeles (33^◦)56' North and (118^◦)24' West and Utrecht (52^◦)06' North and (02^◦)06' East *) 

{LosA,Utre}=ToMinutes[{{{33,56},{-118,-24}},{{52,06},{05,06}}}];

(* loxodrome is straight line on Mercator map *) 

loxo=WorldGraphics[{RGBColor[1,0,0],Dashing[{0.005,0.005}],Line[{LosA,Utre}]}];

(* conversion from geographical coordinates to spherical coordinates in radians *)

(*<<VectorAnalysis`
<<LinearAlgebra`Orthogonalization`*)
x[α_,θ_]:={Cos[α]Cos[θ],Sin[α]Cos[θ],Sin[θ]}
angle[d_,m_]:=(d+(m/60))(π/180)
α1=-angle[118,24];
θ1=angle[33,56];
α2=angle[05,06];
θ2=angle[52,06];
LA=N[x[α1,θ1]];
UT=N[x[α2,θ2]];

(* geodesic = great circle arises as orbit under rotation about axis perpendicular to LA and UT *) 
(* distance and axis of rotatation *)

δ=N[ArcCos[LA.UT]];
n={a1,a2,a3}=N[Normalize[Cross[LA,UT]]];

(* matrix $R_{α}$ of rotation by angle $α$ about axis $n$ *)

r={{0,-a3,a2},{a3,0,-a1},{-a2,a1,0}};
R[α_]:=Cos[α]IdentityMatrix[3]+(1-Cos[α])Transpose[{n}].{n}+Sin[α]r

(* point on geodesic issuing from point LA arising as image under rotation by angle $α$ about axis $(a_1,a_2,a_3)$ *)

geod[α_]:=R[α].LA

(* the description of points in Worldplot has to be in latitude and longitude given in degrees and minutes *)

grminu[θ_]:=60IntegerPart[θ]+IntegerPart[60(θ-IntegerPart[θ])];
lat[α_]:=grminu[(180/π) ArcSin[geod[α][[3]]]];
lon[α_]:=grminu[(180/π) 2ArcTan[geod[α][[2]]/(geod[α][[1]]+Sqrt[geod[α][[1]]^2+geod[α][[2]]^2])]];
Geodesic=Table[Point[{lat[α],lon[α]}],{α,0,δ,0.0001}];
geod=WorldGraphics[{PointSize[0.0006],Geodesic}];

lightblue=RGBColor[220/256,248/256,248/256];
show[{worldmap,loxo,geod},ImageSize->800,Background->lightblue,DisplayFunction->$DisplayFunction];

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
θ=π/3.5;
p[α_]:={Cos[α],Sin[α]}
p1=parametricPlot[p[α],{α,-π,π},PlotStyle->darkblue,DisplayFunction->None];
p2=parametricPlot[0.2p[α],{α,0,θ},PlotStyle->RGBColor[1,0,0],DisplayFunction->None]; 
p3=Graphics[{darkblue,PointSize[0.015],Point[0p[0]],Point[p[π/2]],Point[p[θ]],Point[{Tan[θ/2+π/4],0}]}];
p4=Graphics[{darkblue,Line[{p[θ],0p[0],p[π/2],{Tan[θ/2+π/4],0},0p[0]}]}];
show[p1,p2,p3,p4,Axes->False,Ticks->None,AspectRatio->Automatic,Background->lightblue,ImageSize->600,PlotRange->All,DisplayFunction->$DisplayFunction];

Exercise 5.32  (Local isometry of catenoid and helicoid)

Missing. P427V

Exercise 5.34   (Hypo- and epicycloids)

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
parametricPlot[{3 Cos[t]-Cos[3 t],3 Sin[t]-Sin[3 t]},{t,0,2 π},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],plotPoints->50,AspectRatio->Automatic,Ticks->{{{2,{"a"}}},{{4,{"2a"}}}},Background->lightblue,ImageSize->400];

Exercise 5.35   (Steiner's hypocycloid)

Clear["`*"]
Off[General::spell1]
lightblue=RGBColor[220/256,248/256,248/256];
ϕ[α_]:=b{2Cos[α]+Cos[2α],2Sin[α]-Sin[2α]}
norm[{x1_,x2_}]:=Sqrt[x1^2+x2^2]
f[α_]:=fullSimplify[norm[ϕ[α]],b>0]
f[α]
a=3;
b=a/3;
plot[f[α],{α,0,2π},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,Ticks->{Table[k(π/3),{k,0,6}],{f[(π/3)],2,f[0]}},ImageSize->500];
Reduce[f[α]==a,α]
Reduce[f[α]==b,α]
Reduce[(∂_α) ϕ[α]==0,α]
Simplify[Sin[α]+Sin[2α]==2Sin[3α/2]Cos[α/2],Im[α]==0]
Simplify[Cos[α]-Cos[2α]==2Sin[3α/2]Sin[α/2],Im[α]==0]
Simplify[(∂_α) ϕ[α]==-4Sin[3α/2]{Cos[α/2],-Sin[α/2]},{Sin[α]+Sin[2α]==2Sin[3α/2]Cos[α/2],Cos[α]-Cos[2α]==2Sin[3α/2]Sin[α/2],Im[α]==0}]
Print["Direction of tangent line to H at ϕ(α)"]
{Cos[α/2],-Sin[α/2]}
Print["Direction of normal to H at ϕ(α)"]
sol=Solve[{Cos[α/2],-Sin[α/2]}.{1,kk}==0,kk];
k=kk/.sol;
{k1,k2}=Sin[α/2]Flatten[{1,k}]
Print["Equation of geometric tangent line to H in ϕ(α)"]
Clear[b]
Simplify[{(Subscript[h, 1]),(Subscript[h, 2])}.{k1,k2}==ϕ[α].{k1,k2}]

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
t=0.45 π;
x1=2.75;
x2=(Sin[3 t/2]-x1 Sin[t/2])/Cos[t/2];
y1=-2;
y2=(Sin[3 t/2]-y1 Sin[t/2])/Cos[t/2];
x={x1,x2};
y={y1,y2};
f1[a_]:=2 Cos[a]+Cos[2 a]
f2[a_]:=2 Sin[a]-Sin[2 a]
a=-1;
b=1.5;
p1={a f1[π-t/2]+(3 a+1) f1[-t/2],a f2[π-t/2]+(3 a+1) f2[-t/2]};
p2={b f1[π-t/2]+(3 b+1) f1[-t/2],b f2[π-t/2]+(3 b+1) f2[-t/2]};
c=-0.75;
d=1.5;
q1={c f1[-t/2]+(3 c+1) f1[π-t/2],c f2[-t/2]+(3 c+1) f2[π-t/2]};
q2={d f1[-t/2]+(3 d+1) f1[π-t/2],d f2[-t/2]+(3 d+1) f2[π-t/2]};
lp[x_,c_]:=x (p2-p1)+p1+{0,c}
lq[x_,d_]:=x (q2-q1)+q1+{0,d}
Clear[a];
g1=parametricPlot[{f1[a],f2[a]},{a,0,2 π},plotPoints->300,PlotStyle->RGBColor[1,0,0],AspectRatio->Automatic,Ticks->None,PlotRange->{{-3,3.5},{-3,3}},PlotStyle->AbsoluteThickness[0.8],DisplayFunction->None];
g2=Graphics[{{AbsoluteThickness[0.5],RGBColor[0,0.5,0],Line[{{-3,0},{3.5,0}}],Line[{{0,3},{0,-3}}]},{AbsolutePointSize[5],darkblue,Point[{f1[t],f2[t]}],Point[{f1[π-t/2],f2[π-t/2]}],Point[{f1[-t/2],f2[-t/2]}],Point[{-1/2 (f1[π-t/2]+f1[-t/2]),-1/2 (f2[π-t/2]+f2[-t/2])}],Point[{1/2 (f1[π-t/2]+f1[-t/2]),1/2 (f2[π-t/2]+f2[-t/2])}]},{AbsoluteThickness[0.5],darkblue,Line[{x,y}],Line[{p1,p2}],Line[{q1,q2}]},{AbsoluteThickness[0.5],Dashing[{0.01,0.01}],RGBColor[1,0,0],Circle[{0,0},1]},{AbsoluteThickness[0.5],darkblue,Dashing[{0.015,0.015}],Line[{{-1/2 (f1[π-t/2]+f1[-t/2]),-1/2 (f2[π-t/2]+f2[-t/2])},{1/2 (f1[π-t/2]+f1[-t/2]),1/2 (f2[π-t/2]+f2[-t/2])}}]}}];
g3=show[g1,g2,Ticks->None,DisplayFunction->None];
Clear[x,y];
g4=parametricPlot[lp[x,0.3],{x,0.164582,0.189375},PlotStyle->darkblue,DisplayFunction->None];
g5=parametricPlot[lq[y,-0.7],{y,0.152928,0.17085},PlotStyle->darkblue,DisplayFunction->None];
show[g3,g4,g5,Background->lightblue,ImageSize->900,DisplayFunction->$DisplayFunction];

Exercise 5.36   (Elimination theory: equations for hypo- and epicycloid)

Clear["`*"]
Simplify[Resultant[(Subscript[x, 1])-3+(2(Subscript[x, 1])+6)t^2+((Subscript[x, 1])+1)t^4,(Subscript[x, 2])+2(Subscript[x, 2])t^2-8t^3+(Subscript[x, 2 ])t^4,t]/4096]
Simplify[4096%==2^12(((Subscript[x, 1])^2+(Subscript[x, 2])^2)^2+8(3(Subscript[x, 1])(Subscript[x, 2])^2-(Subscript[x, 1])^3)+18((Subscript[x, 1])^2+(Subscript[x, 2])^2)-27)]

Exercise 5.38.(iv)   (Toroid)

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
b=0.5;
t0=0.3 π;
II[t_]:=1/Sqrt[b^2 Cos[t]^2+Sin[t]^2]
S1[t_]:=Cos[t] (2+b II[t])
S2[t_]:=Sin[t] (2 b+II[t])
T1[t_]:=Cos[t] (2-b II[t])
T2[t_]:=Sin[t] (2 b-II[t])
p1=parametricPlot[{T1[t],T2[t]},{t,0,2 π},plotPoints->50,PlotStyle->{RGBColor[1,0,0],AbsoluteThickness[1]},AspectRatio->Automatic,Ticks->None,DisplayFunction->None];
p2=parametricPlot[{S1[t],S2[t]},{t,0,2 π},plotPoints->50,PlotStyle->{RGBColor[1,0,0],AbsoluteThickness[1]},AspectRatio->Automatic,Ticks->None,DisplayFunction->None];
p3=parametricPlot[{2 Cos[t],2 b Sin[t]},{t,0,2 π},plotPoints->50,PlotStyle->{darkblue,AbsoluteThickness[.75]},AspectRatio->Automatic,Ticks->None,DisplayFunction->None];
p4=Graphics[{AbsoluteThickness[.75],Dashing[{0.02,0.02}],{darkblue,Circle[{2 Cos[t0],2 b Sin[t0]},1]},{AbsolutePointSize[5],Point[{2 Cos[t0],2 b Sin[t0]}]}},AspectRatio->Automatic]
show[p1,p2,p3,p4,AxesStyle->RGBColor[0,0.5,0],ImageSize->600,Background->lightblue,DisplayFunction->$DisplayFunction, PlotRange->All];

Exercise 5.38.(vi)   (Logarithmic spiral)

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
logspiral[a_,b_][t]=a{E^(b t)Cos[t],E^(b t)Sin[t]};
p1=parametricPlot[Evaluate[{logspiral[1,0.08][t]}],{t,-16π,π/3},PlotStyle->RGBColor[1,0,0],AspectRatio->Automatic,Axes->None,PlotRange->{{-1.25,1.25},{-1.25,1.25}},DisplayFunction->None];
p2=Graphics[{AbsoluteThickness[0.75],{RGBColor[0,0.5,0],Line[{{-1.1,0},{1.1,0}}],Line[{{0,1.1},{0,-1.1}}]}}];
show[p1,p2,Background->lightblue,ImageSize->500,DisplayFunction->$DisplayFunction];

Exercise 5.38.(viii)   (Reflected light)

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
a=1;
t=0.2π;
x1=a Cos[t]-0.2;
p1=parametricPlot[{a/2 Cos[tt] (3-2 Cos[tt]^2),a Sin[tt]^3},{tt,0,2π},PlotStyle->RGBColor[1,0,0],plotPoints->50,PlotStyle->AbsoluteThickness[1.25],DisplayFunction->None];
p2=Graphics[{{darkblue,AbsolutePointSize[5],Point[{0,0}],Point[{a Cos[t],a Sin[t]}],Point[{a/2 Cos[t] (3-2 Cos[t]^2),a Sin[t]^3}]},{darkblue,AbsoluteThickness[0.75],{Dashing[{0.015,0.015}],Circle[{0,0},a/2],Circle[{3/4 a Cos[t],3/4 a Sin[t]},a/4]},Circle[{0,0},a]},{RGBColor[180/256,200/256,0],Line[{{-1/4,a Sin[t]},{a Cos[t],a Sin[t]},{x1,x1 Tan[2t]-a Cos[t] Tan[2t]+a Sin[t]}}]},{darkblue,Dashing[{0.025,0.025}],AbsoluteThickness[1],Line[{{a Cos[t],a Sin[t]},{0,0}}]}},AspectRatio->Automatic];
show[p2,p1,Background->lightblue,ImageSize->500,DisplayFunction->$DisplayFunction];

Exercise 5.39

See the file Ex5.39.pdf

Exercise 5.41   (Hölder's, Minkowski's and Young's inequalities)

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
p=4;
q=1/(p-1)+1;
p1=plot[x^(p-1),{x,0,1.6},PlotStyle->RGBColor[1,0,0],AspectRatio->Automatic,Ticks->None,PlotRange->{{-0.2,3},{-0.1,5.5}},PlotStyle->AbsoluteThickness[1.5],plotPoints->50,DisplayFunction->None];
p2=Graphics[{Text["0",{0,0}],Text["a",{11/7,0}],Text["x",{2,0}],Text["y",{0,4}],Text["b",{0,2.5}],Text["f",{2,4}],{Table[{darkblue,Line[{{n/7.32,0},{n/7.32,(n/7.32)^(p-1)}}]},{n,1,11}],Table[{darkblue,Line[{{0,n/4},{(n/4)^(q-1),n/4}}]},{n,1,10}]},{AbsoluteThickness[2],{darkblue,Line[{{11/7.32,0},{11/7.32,2.5}}]},{darkblue,Line[{{0,2.5},{11/7.32,2.5}}]}}}];
show[p1,p2,PlotRange->{{-0.2,2.25},{-0.1,4.5}},AspectRatio->Automatic,AxesStyle->RGBColor[0,0.5,0],Background->lightblue,ImageSize->300,DisplayFunction->$DisplayFunction,defaultFont->12.];

Exercise 5.46   (Diameter of submanifold)

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
r[t_]:=5 Sqrt[t]
s[t_]:=2t+1
f1[t_]:=r[t] Cos[t]
f2[t_]:=s[t] Sin[t]+t-10
g1[t_]=f1'[t];
g2[t_]=f2'[t];
y=5.17984;
x=8.33324;
ay=1;
ax=0.75;
p1=parametricPlot[{f1[t],f2[t]},{t,0.2 π,2.75 π},PlotStyle->RGBColor[1,0,0],plotPoints->100,PlotRange->{{-20,20},{-20,20}},AspectRatio->1,DisplayFunction->None];
p2=Graphics[{{AbsolutePointSize[4],darkblue,Point[{f1[x],f2[x]}],Point[{f1[y],f2[y]}]},Text["x",{f1[x],f2[x]+1}],Text["y",{f1[y],f2[y]-1}],{darkblue,Line[{{f1[x]-ax g1[x],f2[x]-ax g2[x]},{f1[x]+ax g1[x],f2[x]+ax g2[x]}}]},{darkblue,Line[{{f1[y]-ay g1[y],f2[y]-ay g2[y]},{f1[y]+ay g1[y],f2[y]+ay g2[y]}}]},{Dashing[{0.02,0.02}],darkblue,Line[{{f1[x],f2[x]},{f1[y],f2[y]}}]}}];
show[p1,p2,Axes->None,Background->lightblue,ImageSize->600,DisplayFunction->$DisplayFunction];

Exercise 5.51   (Tractrix and pseudosphere)

Mathematica is unable to directly evaluate the integral in part (i), although it is able to find an antiderivative for the integrand.

Clear["`*"]
Off[plot::plnr]
lightblue=RGBColor[220/256,248/256,248/256];

Print["Parts (i) and (ii)"]
int[x_]:=Integrate[Sqrt[1-t^2]/t,{t,x,1},Assumptions->{0<x<1}]
fullSimplify[int[x],{0<x<1}] 
i[t_]=Integrate[Sqrt[1-t^2]/t,t];
f[x_]=i[1]-i[x]
plot[f[x],{x,0,1},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Ticks->None,AspectRatio->1,PlotRange->{-0.2,10},Background->lightblue,ImageSize->500];

Print["Part (iii)"]
Simplify[({x,-f[x]}/.x->Sin[s]),0<s<π/2]
%/.s->θ+π/2

tractrix[s_]:={Sin[s],Cos[s]+Log[Tan[s/2]]}
φ[s_,t_]:={Sin[s] Cos[t],Sin[s] Sin[t],Cos[s]+Log[Tan[s/2]]}
Print["Part (v)"]
Transpose[{φ[s,t]}]
Simplify[Transpose[{(∂_s) φ[s,t]}]]
Transpose[{(∂_t) φ[s,t]}]
Transpose[{Simplify[1/Cos[s] Cross[(∂_s) φ[s,t],(∂_t) φ[s,t]]]}]

p1=parametricPlot[tractrix[s],{s,0.005 π,0.9925 π},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],PlotRegion->{{0.2,0.8},{0.2,0.8}},plotPoints->100,AspectRatio->Automatic,Ticks->None,PlotRange->{{-0.5,1.5},{-2,2}},DisplayFunction->None];
p2=parametricPlot3D[φ[s,t]//Evaluate,{s,0.001,π},{t,0,2π},Axes->None,ViewPoint->{1,-2,1/2},Boxed->False,plotPoints->{80,60},DisplayFunction->None];
show[GraphicsGrid[{{p1,p2}}],Background->lightblue,ImageSize->800,DisplayFunction->$DisplayFunction];

Exercise 5.58   (Exponential of antisymmetric matrix is special orthogonal in  (R^3))

Clear["`*"]
Off[General::spell1]
r[{a1_,a2_,a3_}]:={{0,-a3,a2},{a3,0,-a1},{-a2,a1,0}};
R[p0_,p_List]:=(p0^2-p[[1]]^2-p[[2]]^2-p[[3]]^2)IdentityMatrix[3]+2(Transpose[{p}].{p}+p0*r[p])
co[p_,n_]:=Table[Subscript[p,j],{j,n}]
pv=co[p,3];

Print["Rational parametrization of orthogonal matrix"]
MatrixForm[R[(Subscript[p, 0]),pv]]
Print["Test of orthogonality"]
MatrixForm[Simplify[Transpose[R[p0,pv]].R[p0,pv]]/.p0^2+pv[[1]]^2+pv[[2]]^2+pv[[3]]^2->1]

av=co[a,3];
p0=Cos[(α/2)];
pv=Sin[(α/2)]av;
Print["Same orthogonal matrix in transcendental form"]
MatrixForm[Simplify[TrigReduce[R[p0,pv]]/.av[[1]]^2->1-av[[2]]^2-av[[3]]^2]]

angle[a_List]:=ArcCos[(-1+a[[1,1]]+a[[2,2]]+a[[3,3]])/2]
ax[a_List]:=Simplify[(a-Transpose[a])/(2Sin[angle[a]])]
axis[a_List]:={ax[a][[3,2]],-ax[a][[3,1]],ax[a][[2,1]]}

Print["Example of orthogonal matrix"]
0^2+0^2+3^2+4^2==5^2
rot=R[3/5,{4/5,0,0}];
Simplify[1/25MatrixForm[25rot]]
Print["Angle of rotation in degrees, axis, all eigenvalues and eigenvectors, and characteristic polynomial"]
180/π N[angle[rot]]
axis[rot]
Simplify[Eigensystem[rot]]
Expand[25Det[rot-x IdentityMatrix[3]]]

Print["Example of orthogonal matrix"]
1^2+1^2+3^2+5^2==6^2
rot=R[1/6,{5/6,1/2,1/6}];
Simplify[1/36MatrixForm[36rot]]
Print["Angle of rotation in degrees, axis, all eigenvalues and eigenvectors, and characteristic polynomial"]
180/π N[angle[rot]]
Sqrt[35]axis[rot]
Simplify[Eigensystem[rot]]
Expand[9Det[rot-x IdentityMatrix[3]]]

Print["Example of orthogonal matrix"]
2^2+2^2+4^2+5^2==7^2
rot=R[5/7,{-2/7,4/7,2/7}];
Simplify[1/49 MatrixForm[49rot]]
Print["Angle of rotation in degrees, axis, all eigenvalues and eigenvectors, and characteristic polynomial"]
180/π N[angle[rot]]
Sqrt[6]axis[rot]
Simplify[Eigensystem[rot]]
Expand[49Det[rot-x IdentityMatrix[3]]]

Print["Example of orthogonal matrix"]
1^2+2^2+4^2+10^2==11^2
rot=R[4/11,{-2/11,1/11,-10/11}];
Simplify[1/121 MatrixForm[121rot]]
Print["Angle of rotation in degrees, axis, all eigenvalues and eigenvectors, and characteristic polynomial"]
180/π N[angle[rot]]
Sqrt[105]axis[rot]
Simplify[Eigensystem[rot]]
Expand[121Det[rot-x IdentityMatrix[3]]]

Exercise 5.66  (Reflections, rotations, Cayley-Klein parameters and Sylvester's Theorem)

This is an illustration of Sylvester's Theorem from part (iii). Text has to be added using Xfig.

The code below might be improved.

Clear["`*"]
Off[General::spell];
Off[General::spell1];

(* controlling the output of the graphics *)

lightblue=RGBColor[220/256,248/256,248/256];
raster=0.035;
point=0.001;
thick=0.002;
dash=0.005;

(* polar coordinates $(\alpha,\theta)$ of unit vectors $a_1$ and $a_2$ and angles $\alpha_1$ and $\alpha_2$ of rotation about $p$ and $q$,respectively, all in multiples of $\pi$ *)

ap=4/5;
tp=1/10;
aq=1/10;
tq=1/3;
anglep=1/2;
angleq=2/3;

(* stripping of excess parentheses and definition of norm of vector for purposes of computation of length of vector *)

(*<<LinearAlgebra`Orthogonalization`;*)
Strip[a_]:=Apply[Sequence,a];
norm[a1_,a2_,a3_]:=N[Sqrt[(a1)^2+(a2)^2+(a3)^2]];
normS[a_]:=norm[Strip[a]];

(* transparant unit sphere *)

x[1,a_,t_]:=Cos[a π]Cos[t π];
x[2,a_,t_]:=Sin[a π]Cos[t π];
x[3,a_,t_]:=Sin[t π];
x[a_,t_]:=Table[x[j,a,t],{j,3}];
list=Table[Point[x[a,t]],{a,-π,π,raster},{t,-π/2,π/2,raster}];
S=Graphics3D[{PointSize[point],list},Axes->False,PlotRange->All,AspectRatio->1,Boxed->False];

(* two unit vectors $a_1$ and $a_2$ that determine the axes of rotation $\R p$ and $\R q$ *)

a[1]=a1=x[ap,tp];
a[2]=a2=x[aq,tq];

(* solid lines that give the vectors $a1$ and $a2$ *)

LP=Graphics3D[{RGBColor[1,0,0],Thickness[thick],Line[{0*a1,a1}]}];
LQ=Graphics3D[{RGBColor[1,0,0],Thickness[thick],Line[{0*a2,a2}]}];

(* $x_2$ is normalized cross product of $q$ and $p$ *)

x[2]=x2=Normalize[Cross[a2,a1]];

(* dashed line that gives the vector $x_2$ *)

LX2=Graphics3D[{Thickness[1.75*thick],Dashing[{dash,2*dash}],Line[{0*x2,x2}]}];

(* matrix $R_{a,(a_1,a_2,a_3)}$ of rotation by angle $a$ about axis $(a_1,a_2,a_3)$ *)

r[a1_,a2_,a3_]:={{0,-a3,a2},{a3,0,-a1},{-a2,a1,0}};
R[a_,a1_,a2_,a3_]:=Cos[a]IdentityMatrix[3]+(1-Cos[a])Transpose[{{a1,a2,a3}}].{{a1,a2,a3}}+Sin[a]r[a1,a2,a3];

(* point on geodesic issuing from point $x_2$ arising as image under rotation by angle $a$ about axis $(a_1,a_2,a_3)$ *)

geod[a_,a1_,a2_,a3_]:=R[a,a1,a2,a3].x2;

(* geodesics obtained by rotating $x_2$ by the angle $a$ about the axis $p$ and $q$,resp. *)

geodp[a_]:=R[a,Strip[a1]].x2;
geodq[a_]:=R[a,Strip[a2]].x2;

(* graphics of the segment of the geodesics from $x_2$ to $x_1$ and $x_3$ resp. determined by angle $a$ running between $0$ and $s$ *)

GEODP[s_]:=parametricPlot3D[Evaluate[geodp[a]],{a,0,s},plotPoints->200,DisplayFunction->None];
GEODQ[s_]:=parametricPlot3D[Evaluate[geodq[a]],{a,0,s},plotPoints->200,DisplayFunction->None];

GEODX2X1=GEODP[-anglep*π/2];
GEODX2X3=GEODQ[angleq*π/2];

x[1]=x1=geodp[-anglep*π/2];
x[3]=x3=geodq[angleq*π/2];

(* dashed lines that give the vectors $x_1$ and $x_3$ *)

LX1=Graphics3D[{Thickness[thick],Dashing[{dash,2dash}],Line[{0*x1,x1}]}];
LX3=Graphics3D[{Thickness[thick],Dashing[{dash,2dash}],Line[{0*x3,x3}]}];

(* axis $a_3$ that is the normalized cross product of $x_1$ and $x_3$ *)

a[3]=a3=Normalize[Cross[x1,x3]];

(* solid line that gives the axis of rotation $a3$ *)

LR=Graphics3D[{RGBColor[1,0,0],Thickness[2thick],Line[{0*a3,a3}]}];

(* geodesic connecting $x_1$ and $x_3$ *)

geodr[a_]:=R[a,Strip[a3]].x1;
GEODR[s_]:=parametricPlot3D[Evaluate[geodr[a]],{a,0,s},plotPoints->200,DisplayFunction->None];
angler=2ArcCos[x1.x3];
GEODX1X3=GEODR[angler/2];

p0=Cos[anglep*π/2];
q0=Cos[angleq*π/2];
p=Sin[anglep*π/2] a1;
q=Sin[angleq*π/2] a2;
r=q0 p+p0 q+Cross[q,p];

P=Graphics3D[{PointSize[7point],Point[p]},Shading->False];
Q=Graphics3D[{PointSize[7point],Point[q]},Shading->False];
R=Graphics3D[{PointSize[10point],Point[r]},Shading->False];

{A1,A2,A3}=Table[Graphics3D[{PointSize[7point],Point[a[j]]},Shading->False],{j,3}];
{X1,X2,X3}=Table[Graphics3D[{PointSize[7point],Point[x[j]]},Shading->False],{j,3}];

(* final illustration *)

darkblue=RGBColor[34/256,44/256,162/256];
f=2.2;view=f*Normalize[x1+x2+x3]+{0,0,1};
show[S,LP,LQ,LR,LX1,LX2,LX3,GEODX2X1,GEODX2X3,GEODX1X3/.Line[a_List]->{Thickness[.005],Line[a]},P,Q,R,A1,A2,A3,X1,X2,X3,Axes->False,PlotRange->All,BoxRatios->{1,1,1},AspectRatio->1,Boxed->False,ViewPoint->view,ImageSize->900,BaseStyle->darkblue,Background->lightblue,DisplayFunction->$DisplayFunction];

(* verification *)

N[Normalize[r]]-Map[N,a3]

NEW EXERCISES

New Exercise 0.0

Example of a bounded continuous function f on an open interval that assumes its maximum in the interior of the interval and has a nowhere vanishing derivative.

Clear["`*"]
Off[Solve::verif]
lightblue=RGBColor[220/256,248/256,248/256];
plot[ArcSin[y],{y,-1,1},PlotStyle->RGBColor[1,0,0],AspectRatio->1,AxesStyle->RGBColor[0,0.5,0],Background->lightblue,ImageSize->600];
f[x_]:=ArcSin[2 Sqrt[x]/(x+1)]
f[1]
plot[f[x],{x,0,4},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,ImageSize->600];
g[x_]=f'[x]
fullSimplify[ComplexExpand[g[x]],{Im[x+1]==0,x+1>0}]
fullSimplify[%==-Sign[x-1]/((x+1)Sqrt[x]),Im[x]==0]
Limit[g[x],x->1,Direction->1]
Limit[g[x],x->1,Direction->-1]
plot[g[x],{x,0.0001,4},PlotStyle->RGBColor[1,0,0],AspectRatio->1,AxesStyle->RGBColor[0,0.5,0],Background->lightblue,ImageSize->600];
Solve[g[x]==0,x]

New Exercise 4.0   (Lissajous figures)

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
p1=parametricPlot[{Sin[t],Sin[2t]},{t,0,8π},AspectRatio->1,plotPoints->2000,PlotStyle->RGBColor[1,0,0],Axes->False,Background->lightblue,ImageSize->500,DisplayFunction->None];
p2=parametricPlot[{Sin[2t],Sin[3t]},{t,0,8π},AspectRatio->1,plotPoints->2000,PlotStyle->RGBColor[1,0,0],Axes->False,Background->lightblue,ImageSize->500,DisplayFunction->None];
show[GraphicsGrid[{{p1,p2}}],DisplayFunction->$DisplayFunction];
p3=parametricPlot[{Sin[2t],Sin[5t]},{t,0,8π},AspectRatio->1,plotPoints->2000,PlotStyle->RGBColor[1,0,0],Axes->False,Background->lightblue,ImageSize->500,DisplayFunction->None];
p4=parametricPlot[{Sin[7t],Sin[23t]},{t,0,8π},AspectRatio->1,plotPoints->2000,PlotStyle->RGBColor[1,0,0],Axes->False,Background->lightblue,ImageSize->500,DisplayFunction->None];
show[GraphicsGrid[{{p3,p4}}],DisplayFunction->$DisplayFunction];
parametricPlot[{Cos[33t+0.2π],Sin[61t+19/27π]},{t,0,8π},AspectRatio->1,plotPoints->2000,PlotStyle->RGBColor[1,0,0],Axes->False,Background->lightblue,ImageSize->800];

New Exercise 5.0   (Quadratic equation from geometric point of view)

Clear["`*"]
Off[General::spell1]
Off[N::meprec]
Print["Diagonalization of quadratic form (x^2)+2(Subscript[y, 1])x"]
MatrixForm[A={{1,1},{1,0}}]
(Subscript[τ, +])=Eigenvalues[A][[1]]
(Subscript[τ, -])=Eigenvalues[A][[2]]
fullSimplify[(Subscript[τ, +])==GoldenRatio]
fullSimplify[1/(Subscript[τ, +])==-(Subscript[τ, -])]
a1=Eigenvectors[A][[1]]
a2=-Eigenvectors[A][[2]]
FullSimplify[Norm[a1]==PowerExpand[5^(1/4)Sqrt[(Subscript[τ, +])]]]
FullSimplify[Norm[a2]==PowerExpand[5^(1/4)Sqrt[-(Subscript[τ, -])]]]
MatrixForm[Orth=1/(5^(1/4))Transpose[{{Sqrt[(Subscript[τ, +])],Sqrt[-(Subscript[τ, -])]},{Sqrt[-(Subscript[τ, -])],-Sqrt[(Subscript[τ, +])]}}]]
Simplify[Transpose[Orth].Orth]//MatrixForm
Simplify[Inverse[Orth].A.Orth]//MatrixForm
Simplify[Orth.A.Orth]//MatrixForm
z={z1,z2}=Orth.{x,(Subscript[y, 1])};
Expand[Simplify[(Subscript[τ, +])z1^2+(Subscript[τ, -])z2^2]]

(*<<Graphics`contourPlot3D`*)
lightblue=RGBColor[220/256,248/256,248/256];
p=contourPlot3D[x^2+2y1 x+y2==0,{x,-4,4},{y1,-4,4},{y2,-4,4},PlotPoints->30,PlotRange->{{-3,3},{-2,2},{-2,2}},ViewPoint->{2,1.4,1.6},
ContourStyle->RGBColor[0.7,0.7,1],lightSources->{{{0,2,2},RGBColor[0,1,1]},{2{3,2,0},RGBColor[.7,.7,0]},{0{3,2,0},RGBColor[.4,0,0]}},Background->lightblue,Boxed->False,ImageSize->700,DisplayFunction->None];
thick=0.004;
x=Graphics3D[{Thickness[thick],{RGBColor[1,0,0],Line[{{0,0,0},{6,0,0}}]}}];
y1=Graphics3D[{Thickness[thick],{RGBColor[1,0,0],Line[{{0,0,0},{0,3,0}}]}}];
y2=Graphics3D[{Thickness[thick],{RGBColor[1,0,0],Line[{{0,0,0},{0,0,1}}]}}];
t1=Graphics3D[Text["x-axis",{4.5,0,0},BaseStyle->Large]];
t2=Graphics3D[Text["(Subscript[y, 1])-axis",{0,2.5,0},BaseStyle->Large]];
t3=Graphics3D[Text["(Subscript[y, 2])-axis",{0,0,1.2},BaseStyle->Large]];
show[p,x,y1,y2,t1,t2,t3,TextStyle->{FontFamily->"Times",FontSize->14.},Axes->None,DisplayFunction->$DisplayFunction];

Off[General::spell1]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];

xmax=2.5;
xmin=-xmax;
y1max=xmax;
y1min=-y1max;
y1maxc=xmax;
y1minc=-y1maxc;
planex=-13;
planey2=-28;
view={4,2,6};
raster=0.05;
point=0.001;
dash=0.01;

f[x_,y1_]:=-x^2-2x y1
h[y1_]:=-y1
Clear[x];
xboundaries=parametricPlot3D[{
{x,y1min,f[x,y1min]},               (* left border of surface *)
{x,y1max,f[x,y1max]},               (* right border of surface *)
{x,y1min,planey2},                       (* left line in bottom plane *) 
{x,y1max,planey2},                       (* right line in bottom plane *)
{planex,y1min,f[x,y1min]},   (* projection of left border of surface on back plane *)
{planex,y1max,f[x,y1max]}}, (* projection of right border of surface on back plane *)
{x,xmin,xmax},Axes->False,PlotRange->All,AspectRatio->1,Boxed->False,DisplayFunction->None];
Clear[y1];
y1boundaries=parametricPlot3D[{
{xmax,y1,f[xmax,y1]},              (* front border of surface *)
{xmin,y1,f[xmin,y1]},              (* back border of surface *)
{planex,y1,f[xmax,y1]},         (* projection of front border of surface on back plane *)
{planex,y1,f[xmin,y1]},         (* projection of back border of surface on back plane *)
{xmax,y1,planey2},                      (* front line in bottom plane *)
{xmin,y1,planey2}},                    (* back line in bottom plane *) 
{y1,y1min,y1max},ViewPoint->view,Axes->False,PlotRange->All,AspectRatio->1,Boxed->False,DisplayFunction->None];
crit=parametricPlot3D[{
{h[y1],y1,planey2},
{h[y1],y1,f[h[y1],y1]},
{planex,h[y1],f[h[y1],y1]}
},{y1,y1minc,y1maxc},ViewPoint->view,Axes->False,ViewPoint->view,AspectRatio->1,Boxed->False,DisplayFunction->None];
planes=Graphics3D[{Dashing[{dash,dash}],
Line[{{xmin,y1min,planey2},{planex,y1min,planey2}}],
Line[{{xmin,y1max,planey2},{planex,y1max,planey2}}],
Line[{{planex,y1min,planey2},{planex,y1max,planey2}}],
Line[{{planex,y1min,planey2},{planex,y1min,4}}],
Line[{{planex,y1max,planey2},{planex,y1max,4}}]},
Axes->False,PlotRange->All,AspectRatio->1,Boxed->False,DisplayFunction->None];
list1=Table[{darkblue,Point[{x,y1,f[x,y1]}]},{x,xmin,xmax,raster},{y1,y1min,y1max,raster}];
list2=Table[{darkblue,Point[{x,y1,planey2}]},{x,xmin,xmax,raster},{y1,y1min,y1max,raster}];
list3=Table[{darkblue,Point[{planex,y1,f[x,y1]}]},{x,xmin,xmax,raster},{y1,y1min,y1max,raster}];
cloud=Graphics3D[{PointSize[point],list1,list2,list3},Axes->False,PlotRange->{{xmin,xmax},{y1min,y1max},{-10,16}},AspectRatio->1,Boxed->False,ViewPoint->{viewx,viewy1,viewy2},DisplayFunction->Identity];
t1=Graphics3D[Text["\!\(\*StyleBox[\"S\",\nFontSlant->\"Italic\"]\)",{xmax,y1min-0.5,planey2-0.4}]];
t2=Graphics3D[Text["Σ",{0,y1min-1.8,2.2}]];
t3=Graphics3D[Text["\!\(\*StyleBox[\"P\",\nFontSlant->\"Italic\"]\)",{planex,0,1.5}]];
show[cloud,xboundaries,y1boundaries,crit,planes,t1,t2,t3,TextStyle->{FontFamily->"Times",FontSize->14.},ViewPoint->view,PlotRange->All,BaseStyle->RGBColor[1,0,0],Background->lightblue,ImageSize->700,DisplayFunction->$DisplayFunction];

Clear["`*"]
Off[General::spell1]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
thick=0.003;
l=Graphics3D[{Thickness[thick],RGBColor[0,0.5,0],Line[{{3,0,0},{0,0,0},{0,2,0}}],Line[{{0,0,0},{0,0,1}}]}];
view={1,1.5,2.5};
plotrange={{-5,5},{-4,4},{-4.5,4.5}};
raster=0.02;
point=0.001;
list=Table[{darkblue,Point[{x,y1,-x^2-2y1*x}]},{x,-6,6,raster},{y1,-8,8,raster}];
g1=Graphics3D[{PointSize[point],list},DisplayFunction->Identity];
g2=parametricPlot3D[Append[{-y1,y1,y1^2},RGBColor[1,0,0]]//Evaluate,{y1,-8,8},DisplayFunction->None];
g3=parametricPlot3D[Append[{1.5,-1.5-y,(1.5)^2+3*y},RGBColor[1,0,0]]//Evaluate,{y,-8,8},DisplayFunction->None];
show[l,g1,g2,g3,Axes->False,Boxed->False,BoxRatios->{1,1,2},ViewPoint->view,PlotRange->plotrange,Background->lightblue,ImageSize->700,DisplayFunction->$DisplayFunction];

CHAPTER 6: THEORY

Proposition 6.1.2
Illustration

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
Graphics[{RGBColor[1,0,0],AbsolutePointSize[4.5],Point[{1,0}],Point[{2.5,0}],Point[{4,0}],Point[{5.5,0}],Point[{6.5,0}],Point[{8,0}],Point[{8.5,0}],Point[{9.5,0}],Point[{10.5,0}],Point[{12,0}],Point[{14,0}],Point[{0,2}],Point[{0,3.5}],Point[{0,4.5}],Point[{0,5.5}],Point[{0,7}],Point[{0,8}],Point[{0,9.5}],Point[{0,10.5}],Point[{0,11}],Point[{0,13}],Point[{0,14.5}],Point[{0,16}]}];
Graphics[{AbsoluteThickness[0.5],Dashing[{0.0125,0.0125}],Line[{{1,2},{14,2}}],Line[{{1,3.5},{14,3.5}}],Line[{{1,4.5},{14,4.5}}],Line[{{1,5.5},{14,5.5}}],Line[{{1,7},{14,7}}],Line[{{1,8},{14,8}}],Line[{{1,9.5},{14,9.5}}],Line[{{1,10.5},{14,10.5}}],Line[{{1,11},{14,11}}],Line[{{1,13},{14,13}}],Line[{{1,14.5},{14,14.5}}],Line[{{1,16},{14,16}}],Line[{{1,2},{1,16}}],Line[{{2.5,2},{2.5,16}}],Line[{{4,2},{4,16}}],Line[{{5.5,2},{5.5,16}}],Line[{{6.5,2},{6.5,16}}],Line[{{8,2},{8,16}}],Line[{{8.5,2},{8.5,16}}],Line[{{9.5,2},{9.5,16}}],Line[{{10.5,2},{10.5,16}}],Line[{{12,2},{12,16}}],Line[{{14,2},{14,16}}]}];
Graphics[{AbsoluteThickness[2],Line[{{1,2},{14,2}}],Line[{{1,16},{14,16}}],Line[{{1,2},{1,16}}],Line[{{14,2},{14,16}}],Line[{{4,2},{4,5.5}}],Line[{{5.5,2},{5.5,16}}],Line[{{10.5,2},{10.5,8}}],Line[{{6.5,8},{6.5,9.5}}],Line[{{8,8},{8,14.5}}],Line[{{9.5,8},{9.5,16}}],Line[{{10.5,2},{10.5,8}}],Line[{{12,11},{12,16}}],Line[{{5.5,3.5},{10.5,3.5}}],Line[{{5.5,4.5},{10.5,4.5}}],Line[{{1,5.5},{5.5,5.5}}],Line[{{10.5,7},{14,7}}],Line[{{5.5,8},{14,8}}],Line[{{5.5,9.5},{8,9.5}}],Line[{{2.5,10.5},{5.5,10.5}}],Line[{{9.5,11},{14,11}}],Line[{{1,13},{5.5,13}}],Line[{{5.5,14.5},{9.5,14.5}}],Line[{{2.5,5.5},{2.5,13}}]}];
show[%,%%,%%%,Background->lightblue,BaseStyle->darkblue,ImageSize->600,Axes->True,Ticks->None];

Theorem 6.2.8.(iii)

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
f[x_]:=((Sin[(x^2)])/(x+1))
plot[f[x],{x,0,(3/2)π},PlotRange->{-0.37,0.47},AspectRatio->Automatic,PlotStyle->RGBColor[1,0,0],Axes->{True,False},AxesStyle->RGBColor[0,0.5,0],Background->lightblue,Ticks->None,ImageSize->600];
(SubPlus[f])[x_]:=((Abs[f[x]]+f[x])/2)
(SubMinus[f])[x_]:=((Abs[f[x]]-f[x])/2)
plot[(SubPlus[f])[x],{x,0,(3/2)π},PlotRange->{-0.03,0.47},AspectRatio->Automatic,PlotStyle->RGBColor[1,0,0],Axes->{True,False},AxesStyle->RGBColor[0,0.5,0],Background->lightblue,Ticks->None,ImageSize->600];
plot[(SubMinus[f])[x],{x,0,(3/2)π},PlotRange->{-0.03,0.47},AspectRatio->Automatic,PlotStyle->RGBColor[1,0,0],Axes->{True,False},AxesStyle->RGBColor[0,0.5,0],Background->lightblue,Ticks->None,ImageSize->600];

Example 6.4.4

Clear["`*"]
Off[Integrate::idiv]
lightblue=RGBColor[220/256,248/256,248/256];
f[x_,y_]:=((x-y)/(((x+y))^3))
plot3D[f[x,y],{x,0.001,1},{y,0.001,1},ColorFunction->Hue,Background->lightblue,ClippingStyle->None,plotPoints->{80,80},ViewPoint->{-8,-2.4,1.4},Boxed->False,Axes->None,ImageSize->1000];
plot3D[f[x,y],{x,0.001,1},{y,0.001,1},ColorFunction->Hue,Background->lightblue,ClippingStyle->None,PlotRange->All,plotPoints->{80,80},ViewPoint->{-8,-2.4,1.4},Boxed->False,Axes->None,ImageSize->1000];
(∫_0^1)((∫_0^1)(x/(((x+y))^3))\[DifferentialD]y)\[DifferentialD]x

Integrate[f[x,y],{y,0,1},Assumptions->{0<x<1}]
Integrate[%,{x,0,1}]

Example 6.5.1  
Illustration

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
Simplify[Integrate[(Subscript[x, 1])^2+(Subscript[x, 2])^2+(Subscript[x, 3])^2,{(Subscript[x, 3]),0,a-(Subscript[x, 1])-(Subscript[x, 2])}]==((Subscript[x, 1])^2+(Subscript[x, 2])^2)(a-(Subscript[x, 1])-(Subscript[x, 2]))+(a-(Subscript[x, 1])-(Subscript[x, 2]))^3/3]
Simplify[Integrate[Integrate[(Subscript[x, 1])^2+(Subscript[x, 2])^2+(Subscript[x, 3])^2,{(Subscript[x, 3]),0,a-(Subscript[x, 1])-(Subscript[x, 2])}],{(Subscript[x, 2]),0,a-(Subscript[x, 1])}]==(Subscript[x, 1])^2(a-(Subscript[x, 1]))^2/2+(a-(Subscript[x, 1]))^4/6]
Integrate[Integrate[Integrate[(Subscript[x, 1])^2+(Subscript[x, 2])^2+(Subscript[x, 3])^2,{(Subscript[x, 3]),0,a-(Subscript[x, 1])-(Subscript[x, 2])}],{(Subscript[x, 2]),0,a-(Subscript[x, 1])}],{(Subscript[x, 1]),0,a}]
a=3;
Integrate[Boole[(Subscript[x, 1])+(Subscript[x, 2])+(Subscript[x, 3])≤a]((Subscript[x, 1])^2+(Subscript[x, 2])^2+(Subscript[x, 3])^2),{(Subscript[x, 1]),0,a},{(Subscript[x, 2]),0,a},{(Subscript[x, 3]),0,a}]
a=7;
Integrate[Boole[(Subscript[x, 1])+(Subscript[x, 2])+(Subscript[x, 3])≤a]((Subscript[x, 1])^2+(Subscript[x, 2])^2+(Subscript[x, 3])^2),{(Subscript[x, 1]),0,a},{(Subscript[x, 2]),0,a},{(Subscript[x, 3]),0,a}]

a=11.5;
b1=0.35;
b2=0.45;
x1=3;
x2=4.5;
Graphics3D[{Text["x1",{x1,0,0}],Text["x2",{0,x2,0}],Text["a-x1-x2",{0,0,a-x1-x2}],Text["a",{a,0,0}],Text["a-x1",{0,a-x1,0}],{RGBColor[1,0,0],Line[{{a,0,0},{0,a,0},{0,0,a},{b1 a,0,(1-b1) a}}],Line[{{b2 a,0,(1-b2) a},{a,0,0}}],Line[{{x1,0,0},{x1,a-x1,0},{0,a-x1,0}}]},{RGBColor[1,0,0],Line[{{x1,x2,0},{0,x2,0}}],Line[{{x1,x2,0},{x1,x2,a-x1-x2},{0,0,a-x1-x2}}],Line[{{0,0,0},{a x1/(x1+x2),a x2/(x1+x2),0}}]},{RGBColor[1,0,0],Line[{{a x1/(x1+x2),a x2/(x1+x2),0},{0,0,a}}]},{RGBColor[0,0.5,0],Line[{{a+2,0,0},{0,0,0},{0,a+2,0}}],Line[{{0,0,0},{0,0,a+2}}]},Point[{x1,0,0}],Point[{0,x2,0}],Point[{0,0,a-x1-x2}]},{ViewPoint->{18,9,13},Boxed->False,Axes->False,Ticks->None}];
show[%,Background->lightblue,ImageSize->600,defaultFont->12.];

Example 6.5.2   (Intersection of two cylinders)  
New Illustration

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
Print["Proof using the function Boole"]
Integrate[Boole[x1^2+x2^2≤1&&x1^2+x3^2≤1],{x1,-1,1},{x2,-1,1},{x3,-1,1}]
Print["Proof. I"]
b[x_]:=Sqrt[1-x^2]
Integrate[Integrate[Integrate[1,{x3,-b[x1],b[x1]}],{x2,-b[x1],b[x1]}],{x1,-1,1}]
Print["Proof. II"]
f[(Subscript[x, 1])_]=Integrate[Sqrt[1-(Subscript[x, 1])^2],(Subscript[x, 1 ])]
f[b[(Subscript[x, 1])]]
Integrate[x2 Sqrt[1-x2^2],{x2,0,1}]
Integrate[ArcCos[x2],{x2,0,1}]

c1=parametricPlot3D[Append[{Cos[s],Sin[s],t},SurfaceColor[RGBColor[0.7,1,1]]]//Evaluate,{s,-π,π},{t,-2,2},plotPoints->{121,121},lightSources->{{{2,0,2},RGBColor[1,0,0]},{{2,2,2},RGBColor[0,1,0]},{{0,2,2},RGBColor[0,0,1]}},DisplayFunction->None];
c2=parametricPlot3D[{Cos[s],t,Sin[s]}//Evaluate,{s,-π,π},{t,-2,2},plotPoints->{121,121},lightSources->{{{2,0,2},RGBColor[1,0,0]},{{2,2,2},RGBColor[0,1,0]},{{0,2,2},RGBColor[0,0,1]}},DisplayFunction->None];
l1=parametricPlot3D[{Cos[s],Sin[s],Sin[s]},{s,-π,π},plotPoints->301,DisplayFunction->None];
l2=parametricPlot3D[{Cos[s],Sin[s],-Sin[s]},{s,-π,π},plotPoints->301,DisplayFunction->None];
show[c1,c2,l1,l2,lightSources->{{{2,0,2},RGBColor[1,0,0]},{{2,2,2},RGBColor[0,1,0]},{{0,2,2},RGBColor[0,0,1]},{2{1,-1,-2},RGBColor[0.20,.5,.8]}},ViewPoint->{5,0.5,2},ViewPoint->{5,0.5,2},Boxed->False,Axes->False,Ticks->None,ImageSize->900,Background->lightblue,DisplayFunction->$DisplayFunction];

d1=parametricPlot3D[Append[Boole[-Sin[s]≤t≤Sin[s]]{Cos[s],Sin[s],t},SurfaceColor[RGBColor[0.7,1,1]]]//Evaluate,{s,-π,π},{t,-1,1},plotPoints->{301,301},lightSources->{{{1,0,1},RGBColor[1,0,0]},{{1,1,1},RGBColor[0,1,0]},{{0,1,1},RGBColor[0,0,1]}},DisplayFunction->None];
d2=parametricPlot3D[Append[Boole[Sin[s]≤t≤-Sin[s]]{Cos[s],Sin[s],t},SurfaceColor[RGBColor[0.7,1,1]]]//Evaluate,{s,-π,π},{t,-1,1},plotPoints->{301,301},lightSources->{{{1,0,1},RGBColor[1,0,0]},{{1,1,1},RGBColor[0,1,0]},{{0,1,1},RGBColor[0,0,1]}},DisplayFunction->None];
d3=parametricPlot3D[Boole[-Sin[s]≤t≤Sin[s]]{Cos[s],t,Sin[s]}//Evaluate,{s,-π,π},{t,-1,1},plotPoints->{301,301},lightSources->{{{1,0,1},RGBColor[1,0,0]},{{1,1,1},RGBColor[0,1,0]},{{0,1,1},RGBColor[0,0,1]}},DisplayFunction->None];
d4=parametricPlot3D[Boole[Sin[s]≤t≤-Sin[s]]{Cos[s],t,Sin[s]}//Evaluate,{s,-π,π},{t,-1,1},plotPoints->{301,301},lightSources->{{{1,0,1},RGBColor[1,0,0]},{{1,1,1},RGBColor[0,1,0]},{{0,1,1},RGBColor[0,0,1]}},DisplayFunction->None];
show[d1,d2,d3,d4,l1,l2,lightSources->{{{1,0,1},RGBColor[1,0,0]},{{1,1,1},RGBColor[0,1,0]},{{0,1,1},RGBColor[0,0,1]},{1.5{1.,0.,-.7},RGBColor[1,1,0]}},ViewPoint->{5,0.5,2},Boxed->False,Axes->False,Ticks->None,ImageSize->900,Background->lightblue,DisplayFunction->$DisplayFunction];

e1=parametricPlot3D[Append[{Cos[s],Sin[s],t},FaceForm[RGBColor[0.9,1,0.5],darkblue]]//Evaluate,{s,-π,π},{t,-2,2},plotPoints->{121,121},DisplayFunction->None];
e2=parametricPlot3D[Append[{Cos[s],t,Sin[s]},FaceForm[darkblue,RGBColor[0.9,1,0.5]]]//Evaluate,{s,-π,π},{t,-2,2},plotPoints->{121,121},DisplayFunction->None];
show[e1,e2,l1,l2,lightSources->{{{2,0,2},RGBColor[1,0,0]},{{2,2,2},RGBColor[0,1,0]},{{0,2,2},RGBColor[0,0,1]},{2{1,-1,-2},RGBColor[0.20,.5,.8]}},ViewPoint->{2.5,2,1},Boxed->False,Axes->False,Ticks->None,ImageSize->900,Background->lightblue,DisplayFunction->$DisplayFunction];

Example 6.5.3   (Sharpening a pencil)

Clear["`*"]
Tan[π/6]
Tan[π/12]
Tan[π/2-π/12]
a=7/2;
6Integrate[Integrate[Integrate[1,{(Subscript[x, 3]),-(2+Sqrt[3])Sqrt[(Subscript[x, 1])^2+(Subscript[x, 2])^2],0}],{(Subscript[x, 2]),-Sqrt[3](Subscript[x, 1])/3,Sqrt[3](Subscript[x, 1])/3}],{(Subscript[x, 1]),0,a}]
Simplify[%==12(2+Sqrt[3])/36 (4+3Log[3])a^3]

Example 6.6.5   (Volume of truncated cone)

Clear["`*"]
Simplify[Integrate[(1-s)^2,{s,0,h/t}]==(1-(1-h/t)^3)/3]
Simplify[t a^2(1-(1-h/t)^3)/3/.t->a h/(a-b)]

lightblue=RGBColor[220/256,248/256,248/256];
t=2;
smax=0.4;
ψ[α_,s_]:=(1-s){5+Cos[α]+0.08Cos[15α],Sin[α]+0.08Cos[15α],0}+{0,0,s t}
p1=parametricPlot3D[Append[ψ[α,s],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{α,-π,π},{s,0,smax},Background->lightblue,ViewPoint->{2,1,0.9},plotPoints->{201,101},Boxed->False,Ticks->None,Axes->None,ImageSize->900,DisplayFunction->None];
χ[α_,r_]:=(1-smax){5+r(Cos[α]+0.08Cos[15α]),r(Sin[α]+0.08Cos[15α]),0}+{0,0,smax t}
p2=parametricPlot3D[Append[χ[α,r],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{α,-π,π},{r,0,1},Background->lightblue,ViewPoint->{2,1,0.9},plotPoints->{31,21},Boxed->False,Ticks->None,Axes->None,ImageSize->900,DisplayFunction->None];
show[p1,p2,lightSources->{{{3,-.5,1.2},RGBColor[1,1,.1]},{{6,1,.9},RGBColor[1,.5,0]},{{6,-1,.9},RGBColor[0,0,1]}},Axes->None,Ticks->True,DisplayFunction->$DisplayFunction];

Example 6.6.7   (Newton's potential of a ball)

Clear["`*"]
Integrate[r/Sqrt[r^2+((Subscript[y, 3])-a)^2],{r,0,Sqrt[R^2-(Subscript[y, 3])^2]},Assumptions->{(Subscript[y, 3])^2≤R^2,a-(Subscript[y, 3])>0}]
Integrate[1/2 %,{(Subscript[y, 3]),-R,R},Assumptions->{a>R>0}]

Print["Boundary of solid half cylinder with coordinates (α,(Subscript[y, 3]),r) in order of integration"]
lightblue=RGBColor[220/256,248/256,248/256];
thick=0.004;
R=2;
a=Graphics3D[{Thickness[thick],{RGBColor[0,0.5,0],Line[{{0,0,0},{π+0.5,0,0}}]}}];
y3=Graphics3D[{Thickness[thick],{RGBColor[0,0.5,0],Line[{{0,0,0},{0,2.5,0}}]}}];
r=Graphics3D[{Thickness[thick],{RGBColor[0,0.5,0],Line[{{0,0,0},{0,0,2.5}}]}}];
t1=Graphics3D[Text["α-axis",{π+0.8,0,0}]];
t2=Graphics3D[Text["(Subscript[y, 3])-axis",{0,2.9,0}]];
t3=Graphics3D[Text["r-axis",{0,0,2.7}]];
p1=parametricPlot3D[Append[{α,y33,Sqrt[R^2-y33^2]},SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{α,-π,π},{y33,-R,R},plotPoints->{100,51},DisplayFunction->None]
p2=parametricPlot3D[Append[{π,s y33,s Sqrt[R^2-y33^2]},SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{y33,-R,R},{s,0,1},plotPoints->{50,15},DisplayFunction->None];
show[a,y3,r,t1,t2,t3,p1,p2,ViewPoint->{2,2,0.5},
lightSources->{{5{1,0,0},RGBColor[1,1,.5]},{5{1,0,0},RGBColor[1,1,.5]},{5{-1,0,0},RGBColor[1,1,.5]},{5{0,1,0},RGBColor[1,1,0]},{5{0,2,2},RGBColor[0.5,0,.5]}},
Background->lightblue,Boxed->False,Ticks->None,Axes->None,ImageSize->900,TextStyle->{FontFamily->"Times",FontSize->14.},DisplayFunction->$DisplayFunction];

Formula (6.35)
Illustration

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
R[a_]:={{Cos[a],Sin[a]},{-Sin[a],Cos[a]}}
arrow[x_,y_,h_,b_,a_]:=Polygon[{R[a].{-2 b,-4 h}+{x,y},{x,y},R[a].{2 b,-4 h}+{x,y},R[a].{0,-3 h}+{x,y}}]
plot[{7.5+0.1 x^2,1.5+1/24-1/24 x^2},{x,1,5},AspectRatio->1,PlotStyle->{AbsoluteThickness[1]},Ticks->None,DisplayFunction->None];
Graphics[{{AbsoluteThickness[1],Line[{{-11.5,-1},{-11.5,9}}],Line[{{-12,0},{-4,0}}],Line[{{-1,0},{7,0}}],Line[{{-0.5,-1},{-0.5,9}}],Line[{{1,1.5},{1,7.6}}],Line[{{5,0.5},{5,10}}]},{AbsoluteThickness[2],Line[{{2.5,1.5-1/24 2.5 2.5},{2.5,7.5+0.1 2.5 2.5}}]},{Dashing[{0.01,0.01}],AbsoluteThickness[0.5],Line[{{2.5,0},{2.5,1.5-1/24 2.5 2.5}}],Line[{{-0.5,6},{2.5,6}}]}}];
Graphics[{{AbsoluteThickness[1],Line[{{-10,2},{-10,6}}],Line[{{-10,6},{-6,6}}],Line[{{-6,6},{-6,2}}],Line[{{-6,2},{-10,2}}]},{AbsoluteThickness[2],Line[{{-8.5,2},{-8.5,6}}]},{Dashing[{0.01,0.01}],AbsoluteThickness[0.5],Line[{{-8.5,0},{-8.5,2}}],Line[{{-11.5,5},{-8.5,5}}]}},AspectRatio->Automatic,Axes->True,Ticks->None];
Graphics[{{AbsoluteThickness[1],Line[{{-5,3},{-1.5,3}}]},arrow[-1.5,3,0.15,0.1,π/2],arrow[-8.5,4,0.15,0.1,0],arrow[2.5,4.5,0.15,0.1,0],Text["yn",{-12,5}],Text["(y1...yn-1)",{-8.5,-0.5}],Text["(x1...xn-1)",{2.5,-0.5}],Text["En",{-3,3}],Text["Psi",{-2,6}],Text["R1",{-12,8}],Text["R2",{-1,8}],Text["R1n-1",{-4.5,-0.5}],Text["R2n-1",{6,-0.5}]}];
show[%%%%,%%%,%%,%,BaseStyle->darkblue,AspectRatio->Automatic,PlotRange->{{-13,7},{-4.5,10.5}},Axes->None,Background->lightblue,ImageSize->700,DisplayFunction->$DisplayFunction,defaultFont->12.];

Theorem 6.7.4  
Illustration for the proof

Clear["`*"]
Off[General::spell1]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
g[x_]:=E^(-1/x);
g1=plot[g[x],{x,0.01,1},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],PlotRange->All,plotPoints->2000, Ticks->None,DisplayFunction->None];
g21[x_]:=g[x+2]*g[-1-x];
g2=plot[g21[x],{x,-1.99,-1.01},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],AspectRatio->1/3, plotPoints->2000, Ticks->None,DisplayFunction->None];
pg21[x_]:=NIntegrate[g21[t],{t,-1.99,x}];
h21[x_]:=pg21[x]/pg21[-1];
p1=Plot[h21[x],{x,-1.99,-1.01},PlotStyle->RGBColor[1,0,0], AxesStyle->RGBColor[0,0.5,0],PlotPoints->201, Ticks->None,DisplayFunction->Identity];
p2=Plot[h21[-x],{x,1.01,1.99}, PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],PlotPoints->201, Ticks->None,DisplayFunction->Identity];
p3=plot[1,{x,-1,1}, PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],plotPoints->201, Ticks->None,DisplayFunction->None];
p4=Graphics[{Dashing[{0.01,0.01}],{darkblue,Line[{{1,0},{1,1}}]}}];
p5=Graphics[{Dashing[{0.01,0.01}],{darkblue,Line[{{-1,0},{-1,1}}]}}];
g4=Show[p1,p2,p3, p4,p5, AspectRatio->1/2, AxesOrigin->{-2,0}, Ticks->None];
show[GraphicsGrid[{{g1,p1},{g2,g4}}],ImageSize->900,Background->lightblue,DisplayFunction->$DisplayFunction];

Example 6.10.2   ((∫_ℝ)(e^(-(x^2)))dx = (Sqrt[π]))

Clear["`*"]
(∫_(-∞)^∞)(E^(-(x^2)))\[DifferentialD]x
Integrate[r E^(-r^2),{α,-π,π},{r,0,R}]

Example 6.12.5

Clear["`*"]
f[y_,z_]:=E^(-y^4z^2-z^2)
Integrate[f[y,z],{z,-∞,∞},Assumptions->{Im[y]==0}]
Integrate[%,{y,-∞,∞}]
Integrate[f[y,0],{y,-∞,∞}]
Integrate[f[y,z],{y,-∞,∞},Assumptions->{Im[z]==0,z≠0}]

CHAPTER 7: THEORY

Section 7.3.   (Area equals volume divided by length)

Clear["`*"];
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
(*<<LinearAlgebra`Orthogonalization`*)
Print["Parallelepiped spanned by (Subscript[D, 1])ϕ(y), (Subscript[D, 2])ϕ(y) and (Subscript[ν, 1])(y)"]
a[1]={1,2,0};
a[0]=0a[1];
a[2]={0,1,0};
a[3]=a[1]+a[2];
a[4]=Normalize[Cross[a[1],a[2]]];
Do[a[j_]:=a[j-4]+a[4],{j,5,7,1}];
ta=Table[Point[a[j]],{j,0,7}];
p=Graphics3D[{AbsolutePointSize[7],darkblue,ta},DisplayFunction->None];
l[1]=Line[{a[0],a[1],a[3],a[2],a[0]}];
l[2]=Line[{a[4],a[5],a[7],a[6],a[4]}];
Do[l[j_]:=Line[{a[j-3],a[j+1]}],{j,3,6,1}];
l=Graphics3D[{RGBColor[1,0,0],Table[l[j],{j,1,6}]},ViewPoint->100{1,2,1},DisplayFunction->None];
t=Graphics3D[{Text["0",a[0]+{0.05,-0.1,0}],Text["(Subscript[D, 1])ϕ(y)",a[1]+{0.2,0,0}],Text["(Subscript[D, 2])ϕ(y)",a[2]+{0.2,-0.1,0.05}],Text["(Subscript[ν, 1])(y)",a[4]+{0.4,-0.4,0.35}]},DisplayFunction->None]; 
show[p,l,t,TextStyle->{FontFamily->"Times",FontSize->14.},Boxed->False,Background->lightblue,ImageSize->600,DisplayFunction->$DisplayFunction];

Example 7.4.1

Mathematica's definition of the complete elliptic integral of the second kind with modulus k is not the usual one, as customary in pure mathematics. In fact, E(k) in the book is given by  EllipticE[k^2] in Mathematica. Furthermore,  it is unable to establish a trivial None for this integral.

Clear["`*"]
Print["Circle"]
ϕ[t_]:={ Cos[t],Sin[t]}
Sqrt[Sum[((∂_t) ϕ[t][[j]])^2,{j,1,2}]]
fullSimplify[Integrate[%,{t,0,x}]]

Print["Ellipse with semi-major axis a, semi-minor axis b, semi-focal separation c = (Sqrt[(a^2)-(b^2)])"]
ϕ[t_]:={a Cos[t],b Sin[t]}
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
a=2;
b=1;
c=Sqrt[a^2-b^2];
p1=parametricPlot[ϕ[t],{t,-π,π},AspectRatio->Automatic,PlotRange->{-1.15,1.15},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,Axes->True,Ticks->None,DisplayFunction->None];
p2=Graphics[{AbsolutePointSize[5],darkblue,Point[{c,0}],Point[{-c,0}],Point[ϕ[π/5]],Point[ϕ[π/2]]},PlotRange->{0,3},DisplayFunction->None];
p3=Graphics[{darkblue,Line[{{c,0},ϕ[π/5],{-c,0}}],Line[{{c,0},ϕ[π/2],{-c,0}}]},DisplayFunction->None];
te=Graphics[{Text["a",{0.7,0.7}],Text["b",{-0.1,0.5}],Text["c",{0.7,-0.1}]},DisplayFunction->None]; 
show[p1,p2,p3,te,TextStyle->{FontFamily->"Times",FontSize->14.},ImageSize->500,DisplayFunction->$DisplayFunction, PlotRange->All];
Print["For ellipse with a = 2  and b = 1 the eccentricity e equals"]
e=c/a
Print["while its length is given by"]
N[4a EllipticE[e^2]]
Clear[a,b,c,e]

Sqrt[Sum[((∂_t) ϕ[t][[j]])^2,{j,1,2}]]
fullSimplify[Integrate[%,{t,-π,π},Assumptions->{a>b>0}]]
fullSimplify[Integrate[%,{t,-π,π},Assumptions->{a>b>0}]==4a EllipticE[(a^2-b^2)/a^2]]/.{(1-b^2/a^2)->e^2}

Print["Cycloid"]
ϕ[t_]:={ t-Sin[t],1-Cos[t]}
parametricPlot[ϕ[t],{t,-1.5,2 π+1.5},AspectRatio->Automatic,PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,Axes->True,Ticks->None,ImageSize->500, PlotRange->All];
Sqrt[Sum[((∂_t) ϕ[t][[j]])^2,{j,1,2}]]
fullSimplify[Integrate[%,{t,0,2π}]]

Examples 7.4.2 and 7.4.3

Clear["`*"]
f[t_]:=Sqrt[R^2-t^2]
Simplify[1+f'[t]^2]
2Integrate[Sqrt[%],{t,-R,R},Assumptions->{R>0}]

Print["Special case"]
Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
ϕ[α_]:=f[α]{Cos[α],Sin[α]}
l[f_]:=fullSimplify[Sqrt[Sum[((∂_α) ϕ[α][[j]])^2,{j,1,2}]],Im[α]==0]
l[f]
f[α]=R;
Simplify[Integrate[l[f],{α,0,2π}],R>0]

(*<<Graphics`*)
Print["Cardioid"]
Clear[f]
f[a_]:=2(1+Cos[α])
PolarPlot[f[α],{α,-π,π},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,Axes->True,Ticks->None,ImageSize->400]
Integrate[l[f],{α,0,2π}]
Print["Rose with four petals"]
r[a_]:=Cos[2α]
PolarPlot[r[α],{α,-π,π},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,Axes->False,ImageSize->400]
Print["Rose with twelve petals"]
r[a_]:=Cos[6α]
PolarPlot[r[α],{α,-π,π},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,Axes->False,ImageSize->400]

Section 7.4   II. Area

Clear["`*"]
Do[task=setdel[Format[Derivative[KroneckerDelta[j,1],KroneckerDelta[j,2]][Subscript[f_,i_]][k__]],TraditionalForm[(Subscript[D, j])(Subscript[f, i])[k]]];task/.setdel->SetDelayed,{j,2}]
jacobimatrix[f_,x_List]:= With[{y=Unique[y]&/@x},Table[D[f[y][[i]],y[[j]]],{i,Length[f[y]]},{j,Length[x]}]/. Thread[y->x]]
                d[j_][f_,x_List]:= With[{y=Unique[y]&/@x},Table[(∂_(y[[j]])) f[y][[i]],{i,Length[f[y]]}]/. Thread[y->x]]
co[x_,n_]:=Table[(Subscript[x, j]),{j,n}]

yv=co[y,2];
ϕ[{y1_,y2_}]:={(Subscript[ϕ, 1])[y1,y2],(Subscript[ϕ, 2])[y1,y2],(Subscript[ϕ, 3])[y1,y2]}
ϕ[yv]//MatrixForm
(jac=jacobimatrix[ϕ,yv])//MatrixForm
Transpose[jac].jac//MatrixForm
j1=Sqrt[Det[Transpose[jac].jac]]
{d1,d2}=Table[d[j][ϕ,yv],{j,2}];
d1//MatrixForm
j2=Sqrt[Sum[Cross[d1,d2][[j]]^2,{j,3}]]
Simplify[j1==j2]

Example 7.4.5   (Torus)

Clear["`*"]
ϕ[α_,θ_]:={(2+Cos[θ])Cos[α],(2+Cos[θ])Sin[α],Sin[θ]}
(∂_α) ϕ[α,θ];
(∂_θ) ϕ[α,θ];
c=Simplify[(∂_α) ϕ[α,θ]\[Cross](∂_θ) ϕ[α,θ]]
j=Simplify[(Sqrt[(∑_(j=1)^3)((c[[j]])^2)]),{-(π/2)<θ<(π/2)}]
Integrate[j,{α,-π,π},{θ,-π,π}]

Example 7.4.6   (Cap of sphere and kissing number)

Clear["`*"]
Off[N::meprec]
(* Off[Triangle::shdw] *)
Print["Cap of sphere"]
ϕ[α_,θ_]:=R{Cos[α]Cos[θ],Sin[α]Cos[θ],Sin[θ]}
R=1;
ψ=π/8;
lightblue=RGBColor[220/256,248/256,248/256];
parametricPlot3D[Append[ϕ[α,θ],SurfaceColor[RGBColor[0.7,0.7,0]]//Evaluate],{α,-π,π},{θ,ψ,π/2},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},ViewPoint->{2,1,0.9},plotPoints->{71,31},Ticks->False,Boxed->False,Axes->None,Background->lightblue,ImageSize->600];

Print["Calculation of area of cap of sphere"]
Clear[R,ψ]
(∂_α) ϕ[α,θ]
(∂_θ) ϕ[α,θ]
c=Simplify[(∂_α) ϕ[α,θ]\[Cross](∂_θ) ϕ[α,θ]]
j=Simplify[(Sqrt[(∑_(j=1)^3)((c[[j]])^2)]),{Im[R]==0,-(π/2)<θ<(π/2)}]
Integrate[j,{α,-π,π},{θ,ψ,(π/2)}]
%/.ψ->0

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
Print["Optimal configuration of 6 kissing spheres in dimension 2"]
<<Polytopes`
darkblue=RGBColor[34/256,44/256,162/256];
vert=Vertices[Hexagon];
u=Union[Table[fullSimplify[Norm[ vert[[1]]-vert[[j]]]],{j,1,6}]]
p=Graphics[{PointSize[.01],darkblue,Point/@vert},AspectRatio->1];
v=Join[vert,{vert[[1]]}];
h=Graphics[{RGBColor[1,0,0],Line[v]}];
c=Join[vert,{{0,0}}];
sphere[{x1_,x2_}][α_]:={x1+Cos[α]/2,x2+Sin[α]/2}
s=parametricPlot[Evaluate[Table[sphere[c[[j]]][α],{j,1,7}]],{α,-π,π},PlotStyle->darkblue,Background->lightblue,AspectRatio->Automatic,Axes->False,Ticks->None,plotPoints->99,DisplayFunction->None];
show[p,h,s,ImageSize->800,Background->lightblue,Axes->False,Ticks->None,AspectRatio->Automatic,DisplayFunction->$DisplayFunction]; 

Print["Solid angle subtended by one sphere"]
sphere[{x1_,x2_,x3_}][α_,θ_]:={x1+Cos[α]Cos[θ],x2+Sin[α]Cos[θ],x3+Sin[θ]}
s1=parametricPlot3D[Evaluate[Append[sphere[{0,0,0}][α,θ],SurfaceColor[RGBColor[0.7,0.7,0]]]],{α,-π,π},{θ,π/3,π/2},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},Background->lightblue,AspectRatio->Automatic,Axes->False,Boxed->False,Ticks->None,plotPoints->31,DisplayFunction->None];
s2=parametricPlot3D[Evaluate[Append[sphere[{0,0,0}][α,θ],SurfaceColor[RGBColor[0.7,0.7,1]]]],{α,-3π/2,0},{θ,-π/2,π/3},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},Background->lightblue,AspectRatio->Automatic,Axes->False,Boxed->False,Ticks->None,plotPoints->79,DisplayFunction->None];
s3=parametricPlot3D[Evaluate[Append[sphere[{0,0,2}][α,θ],SurfaceColor[RGBColor[0.7,0.7,1]]]],{α,-π,π},{θ,-π/2,0},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},Background->lightblue,AspectRatio->Automatic,Axes->False,Boxed->False,Ticks->None,plotPoints->99,DisplayFunction->None];
x[α_]:={Cos[α]Cos[-π/6],Sin[α]Cos[-π/6],2+Sin[-π/6]};
step=π/30;
lines=Graphics3D[Table[{RGBColor[1,0,0],Line[{1.35x[α],{0,0,0}}]},{α,-π+step,π,step}]];
show[s1,s2,s3,lines,AspectRatio->1,ViewPoint->{4,4,1.4},Background->lightblue,Axes->False,Boxed->False,Ticks->None,ImageSize->800,PlotRange->All,DisplayFunction->$DisplayFunction];

Print["Estimate of number of kissing spheres in dimension 3"]
Simplify[4/(2-Sqrt[3])==8+4Sqrt[3]]
N[4/(2-Sqrt[3])]
N[Sqrt[8-8/Sqrt[5]]]

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
sphere[{x1_,x2_,x3_}][α_,θ_]:={x1+Cos[α]Cos[θ],x2+Sin[α]Cos[θ],x3+Sin[θ]}
Print["Icosahedron"]
(* PolyhedronData["Icosahedron"] *)
(* <<Polyhedra` *)
show[Graphics3D[PolyhedronData["Icosahedron"][[1]],ViewPoint->{4,2,1},BaseStyle->RGBColor[0.7,0.7,1],lightSources->{{{1,0,0},RGBColor[0,0,1]},{{0,1,0},RGBColor[0,0,1]},{{0,2,2},RGBColor[0,1,1]}},Background->lightblue,Boxed->False,ImageSize->800]];

Print["Realization of 12 kissing spheres in dimension 3"]
vert=(Sqrt[5]-1)*PolyhedronData["Icosahedron","VertexCoordinates"];(*Vertices[Icosahedron];*)
u=Union[Table[fullSimplify[Norm[ vert[[1]]-vert[[j]]]],{j,1,12}]]
Table[N[u[[j]]],{j,1,4}]
f=fullSimplify[Sqrt[8-8/Sqrt[5]]/u[[4]]] 
v=Table[Simplify[f vert[[j]]],{j,1,12}];
c=Join[v,{{0,0,0}}];
s=parametricPlot3D[Evaluate[Table[List[sphere[c[[j]]][α,θ]],{j,1,13}]],{α,-π,π},{θ,-π/2,π/2},lightSources->{{2{1,0,0},RGBColor[1,0,0]},{2{1,0,0},RGBColor[1,0,0]},{2{-1,0,0},RGBColor[1,0,0]},{2{0,1,0},RGBColor[1,1,0]},{2{0,2,2},RGBColor[0,1,1]}},Background->lightblue,AspectRatio->Automatic,Axes->False,Boxed->False,Ticks->None,plotPoints->99,DisplayFunction->None];
show[s,ImageSize->1200,ViewPoint->{4,2,1},Background->lightblue,Axes->False,Boxed->False,Ticks->None,DisplayFunction->$DisplayFunction];

Example 7.4.7

Clear["`*"]
Off[General::spell1]
ϕ[s_][α_,θ_]:=1/2{Cos[α]Cos[θ],Sin[α]Cos[θ],Sin[θ],s}
ϕα=(∂_α) ϕ[1][α,θ]
ϕθ=(∂_θ) ϕ[1][α,θ]
n1=Simplify[Sqrt[Sum[ϕα[[j]]^2,{j,1,4}]],{-π/2<θ<π/2}]
n2=Simplify[Sqrt[Sum[ϕθ[[j]]^2,{j,1,4}]],{-π/2<θ<π/2}]
ϕα.ϕθ
n1 n2
2Integrate[n1 n2,{α,-π,π},{θ,-π/2,π/2}]

Example 7.4.8   (Newton's potential of a sphere)

Clear["`*"]
(1/(4π))Integrate[(((R^2)Cos[θ])/(Sqrt[(R^2)+(a^2)-2a R Sin[θ]])),{θ,-(π/2),(π/2)},{α,-π,π},Assumptions->{0<a<R}]
(1/(4π))Integrate[(((R^2)Cos[θ])/(Sqrt[(R^2)+(a^2)-2a R Sin[θ]])),{θ,-(π/2),(π/2)},{α,-π,π},Assumptions->{0<R<a}]
R=1 ;
lightblue=RGBColor[220/256,248/256,248/256];
lightgreen=RGBColor[220/256,248/256,230/256];
p1=plot[-R,{a,0,1},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,DisplayFunction->None];
p2=plot[-((R^2)/a),{a,1,6},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,DisplayFunction->None];
b1=Graphics[{lightgreen,Polygon[{{0,0},{0,-1-0.05},{1,-1-0.05},{1,0}}]}];
show[b1,p1,p2,PlotRange->{-1-0.05,0},AspectRatio->1,Background->lightblue,ImageSize->600,DisplayFunction->$DisplayFunction];

Example 7.4.10   (Area of two-sphere)

Clear["`*"]
h[y1_,y2_]:=Sqrt[1-(y1^2+y2^2)]
{(∂_(Subscript[y, 1]))h[(Subscript[y, 1]),(Subscript[y, 2])],(∂_(Subscript[y, 2]))h[(Subscript[y, 1]),(Subscript[y, 2])]}
fullSimplify[Sqrt[1+((∂_(Subscript[y, 1]))h[(Subscript[y, 1]),(Subscript[y, 2])])^2+((∂_(Subscript[y, 2]))h[(Subscript[y, 1]),(Subscript[y, 2])])^2],{Im[(Subscript[y, 1])]==Im[(Subscript[y, 2])]==0}]
PowerExpand[fullSimplify[Sqrt[1+((∂_(Subscript[y, 1]))h[(Subscript[y, 1]),(Subscript[y, 2])])^2+((∂_(Subscript[y, 2]))h[(Subscript[y, 1]),(Subscript[y, 2])])^2],{Im[(Subscript[y, 1])]==Im[(Subscript[y, 2])]==0}]]
2Integrate[Boole[y1^2+y2^2<1]/h[y1,y2],{y1,-1,1},{y2,-1,1}]

Example 7.4.11   (Hyperarea of three-sphere)

Clear["`*"]
h[y1_,y2_,y3_]:=Sqrt[1-(y1^2+y2^2+y3^2)]
{(∂_(Subscript[y, 1]))h[(Subscript[y, 1]),(Subscript[y, 2]),(Subscript[y, 3])],(∂_(Subscript[y, 2]))h[(Subscript[y, 1]),(Subscript[y, 2]),(Subscript[y, 3])],(∂_(Subscript[y, 3]))h[(Subscript[y, 1]),(Subscript[y, 2]),(Subscript[y, 3])]}
fullSimplify[Sqrt[1+((∂_(Subscript[y, 1]))h[(Subscript[y, 1]),(Subscript[y, 2]),(Subscript[y, 3])])^2+((∂_(Subscript[y, 2]))h[(Subscript[y, 1]),(Subscript[y, 2]),(Subscript[y, 3])])^2+((∂_(Subscript[y, 3]))h[(Subscript[y, 1]),(Subscript[y, 2]),(Subscript[y, 3])])^2],{Im[(Subscript[y, 1])]==Im[(Subscript[y, 2])]==Im[(Subscript[y, 3])]==0}]
2Integrate[Boole[y1^2+y2^2+y3^2<1]/h[y1,y2,y3],{y1,-1,1},{y2,-1,1},{y3,-1,1}]
2Integrate[Cos[θ]r^2/Sqrt[1-r^2],{α,-π,π},{θ,-π/2,π/2},{r,0,1}]

Formula (7.32)

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
Print["In dimension 2"]
ϕ[y_]:=3/(1+y^3){y^2,y}
v={1,-1};
Ψ[t_,y_]:=ϕ[y]+t v
p1=parametricPlot[Evaluate[Table[Ψ[t,y],{y,0,1,0.005}]],{t,-0.3,0.3},PlotStyle->darkblue,plotPoints->200,DisplayFunction->None];
p2=parametricPlot[Evaluate[ϕ[y]],{y,0,1},PlotStyle->RGBColor[1,0,0],plotPoints->200,DisplayFunction->None];
p3=parametricPlot[Evaluate[ϕ[y]]+{0.003,0.003},{y,0,1},PlotStyle->RGBColor[1,0,0],plotPoints->200,DisplayFunction->None];
show[p1,p2,p3,AspectRatio->Automatic,Axes->False,Background->lightblue,ImageSize->700,DisplayFunction->$DisplayFunction];

Print["In dimension 3"]
ϕ[α_,θ_]:={Cos[α]Cos[θ],Sin[α]Cos[θ],Sin[θ]}
v={1,-1,1};
Ψ[t_,α_,θ_]:=ϕ[α,θ]+t v
p1=Table[Graphics3D[{darkblue,Line[{Ψ[-0.5,α,θ],Ψ[0.5,α,θ]}]},DisplayFunction->Identity],{α,0,π/3,π/101},{θ,0,π/5,π/101}];
p2=parametricPlot3D[Append[ϕ[α,θ],SurfaceColor[RGBColor[1,0,0]]//Evaluate],{α,-π/20,π/2.5},{θ,-π/20,π/4.5},
lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},
plotPoints->20,DisplayFunction->None];
show[p1,p2,ViewPoint->10{1.3,-2.4,2},AspectRatio->Automatic,Boxed->False,Axes->False,Background->lightblue,ImageSize->700,DisplayFunction->$DisplayFunction];

ϕ[α_,θ_]:={Cos[α]Cos[θ],Sin[α]Cos[θ],Sin[θ]}
v={1,-1,1};
Ψ[t_,α_,θ_]:=ϕ[α,θ]+t v
p1=Table[parametricPlot3D[Append[Ψ[t,α,θ],SurfaceColor[darkblue]//Evaluate],{α,0,π/3},{θ,0,π/5},PlotPoints->20,PlotRange->All,ColorFunction->(darkblue&),DisplayFunction->None],{t,-0.545,0.5,0.05}];
p2=parametricPlot3D[Append[ϕ[α,θ],SurfaceColor[RGBColor[1,0,0]]//Evaluate],{α,-π/20,π/2.5},{θ,-π/20,π/4.5},
plotPoints->20,ColorFunction->(Red&),DisplayFunction->None];
show[{p2,p1},ViewPoint->10{1.3,-2.4,2},AspectRatio->Automatic,Boxed->False,Axes->False,Background->lightblue,ImageSize->700,PlotRange->All,DisplayFunction->$DisplayFunction];

Example 7.8.4   (Newton vector field)

Clear["`*"]
(* list of j-th partial derivatives of j-th component function of vector field, for 1 ≤ j ≤ n *)
p[f_,x_List]:= With[{y=Unique[y]&/@x},Table[D[f[y][[j]],y[[j]]],{j,Length[f[y]]}]/. Thread[y->x]]
(* divergence of vector field on (ℝ^n) *) 
d[f_,x_List]:=Simplify[Sum[p[f,x][[j]],{j,1,Length[x]}]]
(* gradient of function on (ℝ^n) *) 
gr[g_,x_List]:=With[{y=Unique[y]&/@x},Table[D[g[y],y[[j]]],{j,Length[y]}]/. Thread[y->x]]
(* Newton vector field on (ℝ^n) up to scalar *) 
f[x_List]:=1/Sqrt[Sum[x[[j]]^2,{j,1,Length[x]}]]^Length[x] x
(* Newton potential up on (ℝ^n) to scalar *) 
g[x_List]:=1/(2-Length[x])1/Sqrt[Sum[x[[j]]^2,{j,1,Length[x]}]]^(Length[x]-2)
(* vector in (ℝ^n) *)
co[x_,n_]:=Table[(Subscript[x, j]),{j,n}]

Print["Dimension"]
n=3
xv=co[x,n];
f[xv]
p[f,xv]
d[f,xv]
g[xv]
gr[g,xv]
%==f[xv]

Print["Dimension"]
n=5
xv=co[x,n];
f[xv]
p[f,xv]
d[f,xv]
g[xv]
gr[g,xv]
%==f[xv]

Print["Dimension"]
n=2
xv=co[x,n];
f[xv]
p[f,xv]
d[f,xv]
g[{x1_,x2_}]:=1/2Log[x1^2+x2^2]
g[xv]
gr[g,xv]
%==f[xv]

Example 7.9.3

Clear["`*"]
Off[General::obspkg];
<<VectorAnalysis`
(* <<LinearAlgebra`Orthogonalization` *)
f[{x1_,x2_,x3_}]:={x1 x3^2,x1^2 x2-x3^3,2x1 x2+x2^2x3}
Div[f[{x1,x2,x3}],Cartesian[x1,x2,x3]]/.Thread[{x1,x2,x3}->{(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])}]

Print["Direct calculation"]
ϕ[α_,θ_]:=a{Cos[α]Cos[θ],Sin[α]Cos[θ],Sin[θ]}
MatrixForm[ϕ[α,θ]]
(Subscript[ω, ϕ])[α_,θ_]:=Simplify[Norm[Cross[(∂_α) ϕ[α,θ],(∂_θ) ϕ[α,θ]]],{a>0,Im[α]==0,0<θ<π/2}]
(Subscript[ω, ϕ])[α,θ]
n[α_,θ_]:=Simplify[Normalize[Cross[(∂_α) ϕ[α,θ],(∂_θ) ϕ[α,θ]]],{a>0,0<θ<π/2}]
MatrixForm[n[α,θ]]
fullSimplify[f[ϕ[α,θ]].n[α,θ](Subscript[ω, ϕ])[α,θ]]
Integrate[f[ϕ[α,θ]].n[α,θ](Subscript[ω, ϕ])[α,θ],{α,-π,π},{θ,0,π/2}]

Print["Calculation by Gauss' Divergence Theorem"]
Table[Integrate[Evaluate[Norm[{x1,x2,x3}]^2Boole[Norm[{x1,x2,x3}]<j]],{x1,-j,j},{x2,-j,j},{x3,0,j}],{j,3}]
%==2 π /5{1^5,2^5,3^5}
n[y1_,y2_]:={0,0,1}
Table[Integrate[f[{y1,y2,0}].n[y1,y2]Boole[Norm[{y1,y2}]<j],{y1,-j,j},{y2,-j,j}],{j,3}]

CHAPTER 8: THEORY

Lemma 8.1.5

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
(j={{0,-1},{1,0}})//MatrixForm
ϕ[α_]:={Cos[α],Sin[α]}

c=parametricPlot[ϕ[α],{α,-π,π},PlotStyle->darkblue,DisplayFunction->None];
α=π/3;
l1=Graphics[{darkblue,Line[{0ϕ[α],ϕ[α]}],Line[{0ϕ[α],j.ϕ[α]}]}];
p1=Graphics[{RGBColor[1,0,0],PointSize[0.025],Point[ϕ[α]]}];
p2=Graphics[{darkblue,PointSize[0.025],Point[0ϕ[α]],Point[j.ϕ[α]]}];
g1=show[c,l1,p1,p2,AspectRatio->Automatic,Axes->False,Background->lightblue];
α=2π/3;
l2=Graphics[{darkblue,Line[{0ϕ[α],ϕ[α]}],Line[{0ϕ[α],j.ϕ[α]}]}];
p3=Graphics[{RGBColor[1,0,0],PointSize[0.025],Point[ϕ[α]]}];
p4=Graphics[{darkblue,PointSize[0.025],Point[0ϕ[α]],Point[j.ϕ[α]]}];
g2=show[c,l2,p3,p4,AspectRatio->Automatic,Axes->False,Background->lightblue];
show[GraphicsGrid[{{g1,g2}}],AspectRatio->Automatic,Background->lightblue,ImageSize->600,DisplayFunction->$DisplayFunction];

Do[task=setdel[Format[Derivative[KroneckerDelta[j,1],KroneckerDelta[j,2]][Subscript[f_,i_]][k__]],TraditionalForm[(Subscript[D, j])(Subscript[f, i])[k]]];task/.setdel->SetDelayed,{j,2}]
jacobimatrix[f_,x_List]:= With[{y=Unique[y]&/@x},Table[D[f[y][[i]],y[[j]]],{i,Length[f[y]]},{j,Length[x]}]/. Thread[y->x]]
f[{x1_,x2_}]:={(Subscript[f, 1])[x1,x2],(Subscript[f, 2])[x1,x2]}
co[x_,n_]:=Table[(Subscript[x, j]),{j,n}]
xv=co[x,2];
t[f_][x_List]=Transpose[j].f[x];
t[f][xv]
Tr[jacobimatrix[t[f],xv]]j

r[{x1_,x2_}]:=j.{x1,x2}
r[xv]
t[r][xv]

Example 8.1.7

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
<<VectorFieldPlots`; 
Off[Power::infy]
Off[∞::indet]
f[x1_,x2_]:={-x2,x1}
VectorFieldPlot[f[x1,x2],{x1,-1,1},{x2,-1,1},ScaleFactor->0.5,PlotPoints->50,ImageSize->400,ColorFunction->Hue,Background->lightblue]
f[x1_,x2_]:={-x2,x1}
f[x1_,x2_]:=(1/((x1^2)+(x2^2))){-x2,x1}
VectorFieldPlot[f[x1,x2],{x1,-1,1},{x2,-1,1},ScaleFactor->0.5,PlotPoints->50,ImageSize->400,ColorFunction->Hue,Background->lightblue]

Lemma 8.1.8

Clear["`*"]
co[x_,n_]:=Table[(Subscript[x, j]),{j,n}]
av=co[a,3];
hv=co[h,3];
kv=co[k,3];
(anti={{0,-(Subscript[a, 3]),(Subscript[a, 2])},{(Subscript[a, 3]),0,-(Subscript[a, 1])},{-(Subscript[a, 2]),(Subscript[a, 1]),0}})//MatrixForm
anti.hv==Cross[av,hv]
(anti.hv).kv==av.Cross[hv,kv]
Simplify[(anti.hv).kv==av.Cross[hv,kv]]

Corollary 8.1.10

Clear["`*"]
Off[General::spell1]
Do[task=setdel[Format[Derivative[KroneckerDelta[j,1],KroneckerDelta[j,2],KroneckerDelta[j,3]][Subscript[f_,i_]][k__]],TraditionalForm[(Subscript[D, j])(Subscript[f, i])[k]]];task/.setdel->SetDelayed,{j,3}]
jacobimatrix[f_,x_List]:= With[{y=Unique[y]&/@x},Table[D[f[y][[i]],y[[j]]],{i,Length[f[y]]},{j,Length[x]}]/. Thread[y->x]]
f[{x1_,x2_,x3_}]:={(Subscript[f, 1])[x1,x2,x3],(Subscript[f, 2])[x1,x2,x3],(Subscript[f, 3])[x1,x2,x3]}
co[x_,n_]:=Table[(Subscript[x, j]),{j,n}]
xv=co[x,3];
hv=co[h,3];
kv=co[k,3];
antif=jacobimatrix[f,xv]-Transpose[jacobimatrix[f,xv]] 
i[j_]:=Mod[j,3,1]
curlf=Table[antif[[i[j+2],i[j+1]]],{j,1,3}] 

Off[General::obspkg];
<<VectorAnalysis`
Curl[f[{x1,x2,x3}],Cartesian[x1,x2,x3]]/.Thread[{x1,x2,x3}->{(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])}]
curlf==%
Simplify[antif.hv==Cross[curlf,hv]]
Simplify[(antif.hv).kv==curlf.Cross[hv,kv]]

Example 8.2.4

Clear["`*"]
(j={{0,-1},{1,0}})//MatrixForm
f[{x1_,x2_}]:=1/(x1^2+x2^2)j.{x1,x2}
xv={(Subscript[x, 1]),(Subscript[x, 2])};
f[xv]
γ[t_]:={Cos[t],Sin[t]}
γ'[t]
f[γ[t]]
Simplify[f[γ[t]].γ'[t]]

Section 8.3

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
lightgreen=RGBColor[220/256,248/256,230/256];
j={{0,-1},{1,0}};
y[t_]:={Cos[t],Sin[t]}
y[t]//MatrixForm
j.y[t]==y'[t]
Simplify[Det[{y[t],y'[t]}]]

y[t_]:=3/(1+t^3){t,t^2}
tt[t_]:=1/Norm[y'[t]]y'[t]
j={{0,-1},{1,0}};
nn[t_]:=1/Norm[y'[t]]Transpose[j].y'[t]
Simplify[j.nn[t]==tt[t]]
fullSimplify[Det[{nn[t],tt[t]}],t>0]

p1=parametricPlot[Evaluate[y[t]],{t,0,100},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,AspectRatio->Automatic,plotPoints->200,Ticks->None,DisplayFunction->None];
p2=parametricPlot[Evaluate[y[t]],{t,0,100},PlotStyle->lightgreen,AxesStyle->RGBColor[0,0.5,0],Background->lightblue,AspectRatio->Automatic,plotPoints->200,Ticks->None,DisplayFunction->None];
p3=p2/.(Line[pts_]:>Polygon[pts]);
l1=Graphics[{RGBColor[1,0,0],Line[{{0,0},{0,0.03}}]}];
t=3/2;
l2=Graphics[{darkblue,Line[{y[t],y[t]+tt[t]}]}];
l3=Graphics[{darkblue,Line[{y[t],y[t]+nn[t]}]}];
a1=Graphics[{darkblue,PointSize[0.013],Point[y[t]],Point[y[t]+tt[t]],Point[y[t]+nn[t]]}];
show[p3,p1,l1,l2,l3,a1,PlotRange->{0.5,2.7},Axes->False,Background->lightblue,ImageSize->500,DisplayFunction->$DisplayFunction];

Example 8.3.2   (Annular domain)

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
lightgreen=RGBColor[220/256,248/256,230/256];
j={{0,-1},{1,0}};

y1[t_]:=4{Cos[t],Sin[t]}
y2[t_]:=2{Cos[t],-Sin[t]}
tt1[t_]:=1/Norm[y1'[t]]y1'[t]
nn1[t_]:=1/Norm[y1'[t]]Transpose[j].y1'[t]
Simplify[j.nn1[t]==tt1[t]]
fullSimplify[Det[{nn1[t],tt1[t]}],t>0]
tt2[t_]:=1/Norm[y2'[t]]y2'[t]
nn2[t_]:=1/Norm[y2'[t]]Transpose[j].y2'[t]
Simplify[j.nn2[t]==tt2[t]]
fullSimplify[Det[{nn2[t],tt2[t]}],t>0]

p1=parametricPlot[Evaluate[y1[t]],{t,-π,π},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,AspectRatio->Automatic,plotPoints->200,Ticks->None,DisplayFunction->None];
p2=parametricPlot[Evaluate[y1[t]],{t,-π,π},PlotStyle->lightgreen,AxesStyle->RGBColor[0,0.5,0],Background->lightblue,AspectRatio->Automatic,plotPoints->200,Ticks->None,DisplayFunction->None];
p3=p2/.(Line[pts_]:>Polygon[pts]);
p4=parametricPlot[Evaluate[y2[t]],{t,-π,π},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,AspectRatio->Automatic,plotPoints->200,Ticks->None,DisplayFunction->None];
p5=parametricPlot[Evaluate[y2[t]],{t,-π,π},PlotStyle->lightblue,AxesStyle->RGBColor[0,0.5,0],Background->lightblue,AspectRatio->Automatic,plotPoints->200,Ticks->None,DisplayFunction->None];
p6=p5/.(Line[pts_]:>Polygon[pts]);
t=2π/3;
g1=Graphics[{darkblue,PointSize[0.011],Point[y1[t]],Point[y1[t]+tt1[t]],Point[y1[t]+nn1[t]]}];
g2=Graphics[{darkblue,Line[{y1[t],y1[t]+tt1[t]}],Line[{y1[t],y1[t]+nn1[t]}]}];
t=π/3;
g3=Graphics[{darkblue,Line[{y2[t],y2[t]+tt2[t]}],Line[{y2[t],y2[t]+nn2[t]}]}];
g4=Graphics[{darkblue,PointSize[0.011],Point[y2[t]],Point[y2[t]+tt2[t]],Point[y2[t]+nn2[t]]}];
show[p3,p6,p1,p4,g1,g2,g3,g4,Axes->False,Background->lightblue,ImageSize->700,DisplayFunction->$DisplayFunction,PlotRange->All];

Clear[p1,p2,p3,p4,p5,p6,l,g1,g2,g3,g4,t];
p1=parametricPlot[Evaluate[y1[t]],{t,0,π},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,AspectRatio->Automatic,plotPoints->200,Ticks->None,DisplayFunction->None];
p2=parametricPlot[Evaluate[y1[t]],{t,0,π},PlotStyle->lightgreen,AxesStyle->RGBColor[0,0.5,0],Background->lightblue,AspectRatio->Automatic,plotPoints->200,Ticks->None,DisplayFunction->None];
p3=p2/.(Line[pts_]:>Polygon[pts]);
p4=parametricPlot[Evaluate[y2[t]],{t,-π,0},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,AspectRatio->Automatic,plotPoints->200,Ticks->None,DisplayFunction->None];
p5=parametricPlot[Evaluate[y2[t]],{t,-π,0},PlotStyle->lightblue,AxesStyle->RGBColor[0,0.5,0],Background->lightblue,AspectRatio->Automatic,plotPoints->200,Ticks->None,DisplayFunction->None];
p6=p5/.(Line[pts_]:>Polygon[pts]);
l=Graphics[{RGBColor[1,0,0],Line[{y1[π],y2[-π]}],Line[{y1[0],y2[0]}]}];
t=2π/3;
g1=Graphics[{darkblue,PointSize[0.011],Point[y1[t]],Point[y1[t]+tt1[t]],Point[y1[t]+nn1[t]]}];
g2=Graphics[{darkblue,Line[{y1[t],y1[t]+tt1[t]}],Line[{y1[t],y1[t]+nn1[t]}]}];
t=-2π/3;
g3=Graphics[{darkblue,Line[{y2[t],y2[t]+tt2[t]}],Line[{y2[t],y2[t]+nn2[t]}]}];
g4=Graphics[{darkblue,PointSize[0.011],Point[y2[t]],Point[y2[t]+tt2[t]],Point[y2[t]+nn2[t]]}];
g5=Graphics[{darkblue,Line[{{2.5,0},{2.5,-1}}],Line[{{2.5,0},{3.5,0}}],Line[{{-3.5,0},{-3.5,-1}}],Line[{{-3.5,0},{-2.5,0}}]}];
g6=Graphics[{darkblue,PointSize[0.011],Point[{2.5,0}],Point[{2.5,-1}],Point[{3.5,0}],Point[{-3.5,0}],Point[{-3.5,-1}],Point[{-2.5,0}]}];
show[p3,p6,l,p1,p4,g1,g2,g3,g4,g5,g6,Axes->False,Background->lightblue,ImageSize->700,DisplayFunction->$DisplayFunction,PlotRange->All];

Clear[p1,p2,p3,p4,p5,p6,l,g1,g2,g3,g4,t];
p1=parametricPlot[Evaluate[y1[t]],{t,-π,0},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,AspectRatio->Automatic,plotPoints->200,Ticks->None,DisplayFunction->None];
p2=parametricPlot[Evaluate[y1[t]],{t,-π,0},PlotStyle->lightgreen,AxesStyle->RGBColor[0,0.5,0],Background->lightblue,AspectRatio->Automatic,plotPoints->200,Ticks->None,DisplayFunction->None];
p3=p2/.(Line[pts_]:>Polygon[pts]);
p4=parametricPlot[Evaluate[y2[t]],{t,0,π},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,AspectRatio->Automatic,plotPoints->200,Ticks->None,DisplayFunction->None];
p5=parametricPlot[Evaluate[y2[t]],{t,0,π},PlotStyle->lightblue,AxesStyle->RGBColor[0,0.5,0],Background->lightblue,AspectRatio->Automatic,plotPoints->200,Ticks->None,DisplayFunction->None];
p6=p5/.(Line[pts_]:>Polygon[pts]);
l=Graphics[{RGBColor[1,0,0],Line[{y1[π],y2[-π]}],Line[{y1[0],y2[0]}]}];
t=-π/3;
g1=Graphics[{darkblue,PointSize[0.011],Point[y1[t]],Point[y1[t]+tt1[t]],Point[y1[t]+nn1[t]]}];
g2=Graphics[{darkblue,Line[{y1[t],y1[t]+tt1[t]}],Line[{y1[t],y1[t]+nn1[t]}]}];
t=π/3;
g3=Graphics[{darkblue,Line[{y2[t],y2[t]+tt2[t]}],Line[{y2[t],y2[t]+nn2[t]}]}];
g4=Graphics[{darkblue,PointSize[0.011],Point[y2[t]],Point[y2[t]+tt2[t]],Point[y2[t]+nn2[t]]}];
g5=Graphics[{darkblue,Line[{{3.5,0},{3.5,1}}],Line[{{2.5,0},{3.5,0}}],Line[{{-2.5,0},{-2.5,1}}],Line[{{-3.5,0},{-2.5,0}}]}];
g6=Graphics[{darkblue,PointSize[0.011],Point[{2.5,0}],Point[{3.5,1}],Point[{3.5,0}],Point[{-3.5,0}],Point[{-2.5,1}],Point[{-2.5,0}]}];
show[p3,p6,l,p1,p4,g1,g2,g3,g4,g5,g6,Axes->False,Background->lightblue,ImageSize->700,DisplayFunction->$DisplayFunction,PlotRange->All];

Example 8.3.6   (Descartes' folium) 
Illustration

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
lightgreen=RGBColor[220/256,248/256,230/256];

y[t_]:=3a/(1+t^3){t,t^2}
y1[t_]:=y[t][[1]]
y2[t_]:=y[t][[2]]
i[t_]=Simplify[y1[t]y2'[t]-y2[t]y1'[t]]
Integrate[1/2i[t],{t,0,∞}]

a=1;
p1=parametricPlot[Evaluate[y[t]],{t,0,100},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,AspectRatio->Automatic,PlotRange->{-0.05,1.65},plotPoints->200,Ticks->None,DisplayFunction->None];
p2=parametricPlot[Evaluate[y[t]],{t,0,100},PlotStyle->lightgreen,AxesStyle->RGBColor[0,0.5,0],Background->lightblue,AspectRatio->Automatic,PlotRange->{-0.05,1.65},plotPoints->200,Ticks->None,DisplayFunction->None];
p3=p2/.(Line[pts_]:>Polygon[pts]);
l=Graphics[{RGBColor[1,0,0],Line[{{0,0},{0,0.03}}]}];
show[p3,p1,l,Background->lightblue,ImageSize->500,DisplayFunction->$DisplayFunction];

Lemma 8.4.2

Clear["`*"]
(* formatting partial derivatives *) 
Format[Derivative[l__][f_][x___]]:=(Subscript[D, First@First[Position[List[l],j_/;j>0]]])f[x];
(* formatting Jacobi matrices *)
jacobimatrix[f_,x_List]:= With[{y=Unique[y]&/@x},Table[(∂_(y[[j]])) f[y][[i]],{i,Length[f[y]]},{j,Length[x]}]/. Thread[y->x]]
(* column vector of Jacobi matrix *) 
                d[j_][f_,x_List]:= With[{y=Unique[y]&/@x},Table[(∂_(y[[j]])) f[y][[i]],{i,Length[f[y]]}]/. Thread[y->x]]
(* antisymmetrized Jacobi matrix *)
anti[f_,x_List]:=jacobimatrix[f,x]-Transpose[jacobimatrix[f,x]] 
(* curl of vector field in (ℝ^3) *) 
i[j_]:=Mod[j,3,1]
curl3[f_,x_List]:=Table[anti[f,x][[i[j+2],i[j+1]]],{j,Length[x]}] 
(* curl of vector field in (ℝ^2) *) 
curl2[g_,y_List]:=anti[g,y][[2,1]]
co[x_,n_]:=Table[(Subscript[x, j]),{j,n}]

xv=co[x,3];
yv=co[y,2];
f[{x1_,x2_,x3_}]:={(Subscript[f, 1])[x1,x2,x3],(Subscript[f, 2])[x1,x2,x3],(Subscript[f, 3])[x1,x2,x3]}
ϕ[{y1_,y2_}]:={(Subscript[ϕ, 1])[y1,y2],(Subscript[ϕ, 2])[y1,y2],(Subscript[ϕ, 3])[y1,y2]}

Print["The mappings"] 
f[xv]
curl3[f,xv]
ϕ[yv]
f[ϕ[yv]]
Print["The left-hand side"] 
g[y_]:=Transpose[jacobimatrix[ϕ,y]].f[ϕ[y]]
g[yv]//MatrixForm
c1=curl2[g,yv]
Print["The right-hand side"] 
curl3[f,ϕ[yv]]
cr=Cross[d[1][ϕ,yv],d[2][ϕ,yv]]
c2=curl3[f,ϕ[yv]].cr
Print["The formula"] 
Simplify[c1==c2]

Remark on compatible orientations

Clear["`*"]
Off[General::spell1]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
rmin=0;
rmax=0.5;
αmin=-π;
αmax=π;
nr=59;
nα=99;
f[x1_,x2_]:=(x1^2)-x1 (x2^3)
x1[r_,α_]:=r Cos[α]
x2[r_,α_]:=r Sin[α]
x3[r_,α_]:=f[x1[r,α],x2[r,α]]
x[r_,α_]:={x1[r,α],x2[r,α],x3[r,α]}
g=parametricPlot3D[Append[x[r,α],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{r,rmin,rmax},{α,αmin,αmax},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},plotPoints->{nr,nα},Boxed->False,Axes->False,Ticks->None,DisplayFunction->None];

p1=x[0.5,π];
t1={(∂_α) x1[r,α],(∂_α) x2[r,α],(∂_α) x3[r,α]}/.{r->0.5,α->π};
c1=Cross[{(∂_r) x1[r,α],(∂_r) x2[r,α],(∂_r) x3[r,α]},{(∂_α) x1[r,α],(∂_α) x2[r,α],(∂_α) x3[r,α]}]/.{r->0.5,α->π};
n1=0.5/Norm[c1] c1;
l1=Graphics3D[{darkblue,Thickness[0.004],Line[{p1,p1+Cross[t1,n1]}]}];
l2=Graphics3D[{RGBColor[1,0,0],Thickness[0.004],Line[{p1,p1+0.5t1}]}];
l3=Graphics3D[{RGBColor[0,0.5,0],Thickness[0.004],Line[{p1,p1+0.5n1}]}];

p2=x[0.5,0];
t2={(∂_α) x1[r,α],(∂_α) x2[r,α],(∂_α) x3[r,α]}/.{r->0.5,α->0};
c2=Cross[{(∂_r) x1[r,α],(∂_r) x2[r,α],(∂_r) x3[r,α]},{(∂_α) x1[r,α],(∂_α) x2[r,α],(∂_α) x3[r,α]}]/.{r->0.5,α->0};
n2=0.5/Norm[c2] c2;
l4=Graphics3D[{darkblue,Thickness[0.004],Line[{p2,p2+Cross[t2,n2]}]}];
l5=Graphics3D[{RGBColor[1,0,0],Thickness[0.004],Line[{p2,p2+0.5t2}]}];
l6=Graphics3D[{RGBColor[0,0.5,0],Thickness[0.004],Line[{p2,p2+0.5n2}]}];

Print["Blue is tangent vector pointing outward, red is positive vector tangent to boundary, green is normal vector"]
show[g,l1,l2,l3,l4,l5,l6,PlotRange->All,Background->lightblue,ViewPoint->3{4,2,0.7},ImageSize->1000,DisplayFunction->$DisplayFunction];

Example 8.5.1

Clear["`*"];
Off[General::spell1]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];

x1[a_,t_]:=Cos[a]Cos[t];
x2[a_,t_]:=Sin[a]Cos[t];
x3[a_,t_]:=Sin[t];
x[a_,t_]:={x1[a,t],x2[a,t],1+x3[a,t]};

raster=0.04;
point=0.001;
list1=Table[Point[x[a,t]],{a,-π,π,raster},{t,-(π/2)+0.01,(π/2)-0.01,raster}];
sphere=Graphics3D[{PointSize[point],darkblue,list1},Axes->False,PlotRange->All,AspectRatio->1,Boxed->False,DisplayFunction->Identity];

n=Graphics3D[{RGBColor[1,0,0],PointSize[0.01],Point[x[0,(π/2)]]}];

ψ=-(π/10);
γ[α_]:=x[α,ψ]
circ=parametricPlot3D[Evaluate[γ[α]],{α,-π,π},Axes->False,PlotRange->All,AspectRatio->Automatic,Boxed->False,DisplayFunction->None];

μ[θ_]:=x[π,θ]
mer=parametricPlot3D[Evaluate[μ[θ]],{θ,ψ,(π/2)},Axes->False,AspectRatio->1,Boxed->False,DisplayFunction->None];

show[sphere,circ,mer,n,ViewPoint->3{3,1.5,1},AspectRatio->Automatic,ImageSize->900,Background->lightblue,BaseStyle->RGBColor[1,0,0],DisplayFunction->$DisplayFunction];

Example 8.5.3 
Illustration

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
moebius[t_,a_]:={Cos[a](1+t Cos[a/2] ),Sin[a](1+t Cos[a/2] ),t Sin[a/2]}
parametricPlot3D[Append[moebius[t,a],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{a,0,2π},{t,-.5,.5},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]},{{-2,-2,0},RGBColor[.4,0,0]}},plotPoints->{80,10},Axes->None,Boxed->False,ViewPoint->{0,-4,3},AspectRatio->0.6,Background->lightblue,ImageSize->600];

CHAPTER 6: EXERCISES

Exercise 6.2

Clear["`*"]
Integrate[(1/(((x1+x2))^2)),{x1,0,1},{x2,1,2}]

Exercise 6.3

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
lightgreen=RGBColor[220/256,248/256,230/256];
Solve[x2^2==2x2,x2]/.{Rule->Equal}

p1=contourPlot[x1==x2,{x1,0,2.5},{x2,0,2.5},BaseStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,DisplayFunction->None];
p2=contourPlot[x2^2==2x1,{x1,0,2.5},{x2,0,2.5},BaseStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,DisplayFunction->None];
p3=contourPlot[x2^2==2x1,{x1,0,2},{x2,0,2.5},BaseStyle->lightgreen,AxesStyle->RGBColor[0,0.5,0],Background->lightblue,DisplayFunction->None];
p4=p3/.(Line[pts_]:>Polygon[pts]);
show[p4,p1,p2,PlotRange->{0,2.5},Background->lightblue,ImageSize->600,DisplayFunction->$DisplayFunction];
Integrate[Boole[x2^2/2≤x1≤x2],{x2,0,2},{x1,0,2}]

Exercise 6.4

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
Integrate[x1^2+x2^2,{x1,0,1},{x2,0,1}]
parametricPlot3D[Append[{r Cos[α],r Sin[α],r^2},SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{α,-π,π},{r,0,2},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},plotPoints->{121,121},ViewPoint->{-1,-2,0.6},PlotRange->{{0,1},{0,1},{0,2}},Ticks->False,BoxStyle->RGBColor[0,0.5,0],BoxRatios->{1,1,1},Boxed->True,Background->lightblue,ImageSize->600];

Exercise 6.6

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
a=3;
p1=plot3D[x^2+y^2,{x,-4,4},{y,-4,4},lightSources->{{{1,0,-1},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},plotPoints->60,DisplayFunction->None];
p2=parametricPlot3D[Append[{a Cos[t],a Sin[t],s},SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{t,0,2 π},{s,0,30},lightSources->{{{-30,-10,15},RGBColor[.5,0,0]},{{1,0,-1},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},plotPoints->{80,30},DisplayFunction->None];
show[p1,p2,ViewPoint->{-30,-10,-10},lightSources->{{2{1,-3,-3},RGBColor[1,.3,0]},{{0,0,15},RGBColor[1,.5,0]},{5{-1,0,1},RGBColor[0,1,0]},{-5{1,-3,-3},RGBColor[0,.3,1]}},Boxed->False,Axes->None,Background->lightblue,ImageSize->700,DisplayFunction->$DisplayFunction];

Print["Direct calculation"]
Integrate[Boole[0⩽x3⩽x1^2+x2^2≤a^2],{x1,-a,a},{x2,-a,a},{x3,0,a^2}]
a=4;
Integrate[Boole[0⩽x3⩽x1^2+x2^2≤a^2],{x1,-a,a},{x2,-a,a},{x3,0,a^2}]

Print["Successive integration"]
Clear[a]
f[x1_,x2_]=Integrate[1,{x3,0,x1^2+x2^2}];
f[(Subscript[x, 1]),(Subscript[x, 2])]
f[x1_]=Integrate[f[x1,x2],{x2,-Sqrt[a^2-x1^2],Sqrt[a^2-x1^2]},Assumptions->{a>x1}];
f[(Subscript[x, 1])]
Integrate[f[x1],{x1,-a,a},Assumptions->{a>0}]

Exercise 6.7

Clear["`*"]
Integrate[x1^2x2^2Boole[x1^2+x2^2≤1],{x1,-1,1},{x2,-1,1}]

Exercise 6.8

Clear["`*"]
Integrate[Boole[Norm[{x1,x2,x3}]⩽1]x1 x2 x3 Norm[{x1,x2,x3}],{x1,-1,1},{x2,-1,1},{x3,-1,1}]

Exercise 6.9

Mathematica detects a mistake in the book.

Clear["`*"]
Off[N::meprec]
f[x1_,x2_]:=1/Sqrt[x1^2+x2^2]
plot3D[1/Sqrt[x1^2+x2^2],{x1,-1,1},{x2,-1,1},BaseStyle->RGBColor[0.7,0.7,1],lightSources->{{{1,0,0},RGBColor[0,0,1]},{{-1,0,0},RGBColor[0,0,1]},{{0,1,0},RGBColor[0,1,1]},{{0,2,2},RGBColor[0,1,1]}},PlotRange->{0,100},plotPoints->120,ViewPoint->{2,0,0.5},Boxed->False,Axes->None,ImageSize->800];
Print["Direct evaluation"]
Integrate[f[x1,x2],{x1,-1,1},{x2,-1,1}]
a=8Log[1+Sqrt[2]]
fullSimplify[%%==a]
Print["Successive integration"]
f1[x1_,x2_]=Integrate[f[xx1,x2],xx1]/.xx1->x1;
f1[(Subscript[x, 1]),(Subscript[x, 2])]
g[x2_]:=f1[1,x2]-f1[-1,x2];
g[(Subscript[x, 2])]
g1[x2_]:=Integrate[g[xx2],xx2]/.xx2->x2;
g1[(Subscript[x, 2])]
g1[1]-g1[-1]
fullSimplify[%==a]

Exercise 6.10

Clear["`*"]
Integrate[Boole[1⩽x1⩽E^x3&&x2⩾x3&&x2^2+x3^2⩽4]/x1,{x1,1,E^2},{x2,-2,2},{x3,-2,2}]

Exercise 6.14

Clear["`*"]
Integrate[Boole[x1^2/a^2+x2^2/b^2≤1],{x1,-a,a},{x2,-b,b},Assumptions->{a>0,b>0}]

Exercise 6.15

Mathematica is not very skillful in handling these integrals. See also the file Ex6.15.pdf.

Clear["`*"]
fullSimplify[Integrate[E^(-x^2),{x,0,a}]^2==Integrate[2E^(-r^2)r,{α,0,π/4},{r,0,a/Cos[α]}],a>0]
fullSimplify[Integrate[2E^(-r^2)r,{α,0,π/4},{r,0,a/Cos[α]}]==π/4-Integrate[E^(-a^2/Cos[α]^2),{α,0,π/4}],a>0]
fullSimplify[Distribute[Integrate[2E^(-r^2)r,{α,0,π/4},{r,0,a/Cos[α]}]]==π/4-Integrate[E^(-a^2/Cos[α]^2),{α,0,π/4}],a>0]
f[a_]:=Integrate[E^(-x^2),{x,0,aa}]^2+Integrate[E^(-aa^2(1+t^2))/(1+t^2),{t,0,1}]/.aa->a
fullSimplify[f[a],a>0]
(∂_a) f[a]
f[0]

Exercise 6.16

Clear["`*"]
Off[N::meprec]
Simplify[Integrate[Boole[0≤x1≤1&&0≤x2≤1-x1]E^((x1-x2)/(x1+x2)),{x1,0,1},{x2,0,1}]==Sinh[1]/2]

Exercise 6.17

In executing this exercise Mathematica has been aborted after two hours of runtime.

(* Clear["`*"] 
fullSimplify[Integrate[Boole[a<Norm[{x1,x2,x3}]<b]/Norm[{x1,x2,x3}]^3,{x1,-b,b},{x2,-b,b},{x3,-b,b},Assumptions->{0<a<b}]==4π Log[b/a],{0<a<b}] *)

Exercise 6.20

Mathematica is unable to evaluate the integral using the function Boole. See also the file Ex6.20.pdf

Clear["`*"]
f[y1_,y2_,y3_]=Integrate[Cos[{x1,x2,x3}.{y1,y2,y3}]Boole[x1^2+x2^2+x3^2≤1],{x1,-1,1},{x2,-1,1},{x3,-1,1},Assumptions->{Im[y1]==0,Im[y2]==0,Im[y3]==0}];
g[y_List]=4π/Norm[y]^2(Sin[Norm[y]]/Norm[y]-Cos[Norm[y]])
fullSimplify[f[y1,y2,y3]==g[{y1,y2,y3}],{Im[y1]==0,Im[y2]==0,Im[y3]==0}]

Exercise 6.21

Mathematica is unable to evaluate the integral.

Clear["`*"]
fullSimplify[Integrate[E^(x1^2+x2^2-x1^2x2^2)Sqrt[1-x1^2],{x1,0,1},{x2,0,1}]==π(E-1)/4]/.x1->(Subscript[x, 1])

Exercise 6.23

See the file Ex6.23.pdf

Exercise 6.36   (Sard's Theorem)

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
R[a_]:={{Cos[a],Sin[a]},{-Sin[a],Cos[a]}}
arrow[x_,y_,h_,b_,a_]:=Polygon[{R[a].{-2 b,-4 h}+{x,y},{x,y},R[a].{2 b,-4 h}+{x,y},R[a].{0,-3 h}+{x,y}}]
d=1.6;
a=2/3;
x0=Sqrt[4/(1+a^2)];
y[x_]:=a x
y1[x_]:=a x+d
y2[x_]:=a x-d
y3[x_]:=-1/a x+x0 (a+1/a)
y4[x_]:=-1/a x-x0 (a+1/a)
y5[x_]:=a x-2 d
y6[x_]:=-1/a x-x0 (a+1/a)-d
p13={(x0 (a+1/a)-d)/(a+1/a),y1[(x0 (a+1/a)-d)/(a+1/a)]};
p23={(x0 (a+1/a)+d)/(a+1/a),y2[(x0 (a+1/a)+d)/(a+1/a)]};
p14={(-x0 (a+1/a)-d)/(a+1/a),y1[(-x0 (a+1/a)-d)/(a+1/a)]};
p24={(-x0 (a+1/a)+d)/(a+1/a),y2[(-x0 (a+1/a)+d)/(a+1/a)]};
Graphics[{Text["a",{0,-0.2}],Text["L",{3,y[2.8]}],Text["e",{-2.75,y[-2.75]}],Text["m",{1.5,-2.5}],{AbsolutePointSize[4],Point[{0,0}]},{AbsoluteThickness[1],Circle[{0,0},2],Line[{{-2.5,y[-2.5]},{3,y[3]}}],Line[{{-2.95,y[-2.95]},{-3.25,y[-3.25]}}],Line[{{-3.1,y6[-3.1]},{-1.7,y6[-1.7]}}],Line[{{-0.125,y5[-0.125]},{3.05,y5[3.05]}}],{Dashing[{0.02,0.02}],Line[{{-4,y1[-4]},{2.5,y1[2.5]}}],Line[{{-2.5,y2[-2.5]},{4,y2[4]}}]},{Dashing[{0.01,0.01}],Line[{p23,{3.3,y3[3.3]}}],Line[{p24,{-0.025,y4[-0.025]}}]}},{AbsoluteThickness[1.75],Line[{p13,p23,p24,p14,p13}]},arrow[-3.1,y6[-3.1],0.075,0.06,-0.185 π],arrow[-1.7,y6[-1.7],0.075,0.06,0.81 π],arrow[-0.125,y5[-0.125],0.075,0.06,1.31 π],arrow[3.05,y5[3.05],0.075,0.06,0.31 π]},AspectRatio->Automatic];
show[%,BaseStyle->darkblue,Background->lightblue,defaultFont->12.,ImageSize->500];

Exercise 6.39   (zeta function and dilogarithm)

Clear["`*"]
Print["Part (i)"]
Sum[1/(2n+1)^2,{n,0,∞}]
Integrate[1/(1-x1^2x2^2),{x1,0,1},{x2,0,1}]
Print["Part (ii)"]
Zeta[2]
N[Zeta[2],20]
N[Zeta[2]-Sum[1/n^2,{n,1,10000}],12]
Print["Part (iii)"]
Integrate[1/x Log[(1+x)/(1-x)],{x,0,1}]
f[x_]=Integrate[1/(1-x1^2x2^2),{x1,0,1},Assumptions->{0<x2<1}]/.x2->x
Integrate[Normal[Series[f[xx],{xx,0,20}]],{xx,0,x}]
Integrate[Normal[Series[Log[1-xx]/xx,{xx,0,20}]],{xx,0,x}]
Print["Part (iv)"]
Sum[(-1)^n/(2n+1)^2,{n,0,∞}]
Integrate[1/(1+x1^2x2^2),{x1,0,1},{x2,0,1}]
Integrate[ArcTan[x]/x,{x,0,1}]
N[%]
Integrate[Log[Sin[t]],{t,0,π/2}]
Integrate[-Log[Abs[2Sin[t/2]]],{t,0,π/2}]
Print["Part (v)"]
Integrate[1/(1-x1^4x2^4),{x1,0,1},{x2,0,1}]
Print["Part (vi)"]
Integrate[1/(1-x1 x2),{x1,0,1},{x2,0,1}]
Integrate[Log[x1 x2]/(1-x1 x2),{x1,0,1},{x2,0,1}]

Exercise 6.40

In part (ii) Mathematica is unable to produce the standard expressions for ζ(2n) in terms of the Bernoulli numbers, neither is it able  to give the standard evaluation in terms of Euler numbers for the series.

Clear["`*"]
Off[fullSimplify::fas]
Print["Part (iv)"]
b[n_]:=(-1)^(n-1) 1/2 (2π)^(2n)BernoulliB[2n]/(2n)!
fullSimplify[Zeta[2n]-b[n],{Element[n,Integers],n>0}]
Table[b[n],{n,1,10}]
c[n_]:=fullSimplify[Zeta[2n]-b[n],{Element[n,Integers],n>0}]
Table[c[n],{n,1,10}]
d[n_]:=fullSimplify[Sum[(-1)^k/(2k+1)^(2n+1),{k,0,∞}],{Element[n,Integers],n>0}]
d[n]
Table[(-1)^n EulerE[2n],{n,1,10}]
e[n_]:=1/2(-1)^n(π/2)^(2n+1)EulerE[2n]/(2n)!
Table[e[n],{n,0,10}]
f[n_]:=fullSimplify[d[n]-e[n],{Element[n,Integers],n>-1}]
Table[f[n],{n,0,9}]

Exercise 6.43

Clear["`*"]
f[x_]:=1/(σ Sqrt[2π])E^(-(x-μ)^2/(2 σ^2))
Integrate[f[x],{x,-∞,∞},Assumptions->{σ>0}]
Integrate[(x-μ)f[x],{x,-∞,∞},Assumptions->{σ>0}]
Integrate[(x-μ)^2f[x],{x,-∞,∞},Assumptions->{σ>0}]

Exercise 6.49

See the file Ex6.49.pdf.

Exercise 6.50   (Euler's Gamma and Beta functions)

Mathematica is unable to recognize the Beta function in part (ii) and cannot simplify the trigonometric integral in part (vii). See also the file Ex6.50.pdf.

Clear["`*"]
Off[N::meprec]
lightblue=RGBColor[220/256,248/256,248/256];
hoek=0.03{1,1};
pic1=plot[Gamma[p],{p,0.025,5},plotPoints->200,Ticks->{{1,2,3,4,5},{5,15,25}},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],PlotRange->{{0,6},{0,30}},PlotRegion->{{0.15,0.9},{0.15,0.9}},DisplayFunction->None];
pic2=plot3D[Beta[p1,p2],{p1,hoek[[1]],1},{p2,hoek[[2]],1},plotPoints->{40,30},ViewPoint->{1.5,2.5,0.7},Axes->None,PlotRange->{0,Beta@@hoek},PlotRegion->{{0,1},{0,1}},Boxed->False,DisplayFunction->None];
pic3=parametricPlot3D[{0,0,t},{t,0,95},BaseStyle->RGBColor[0,0.5,0],plotPoints->100,DisplayFunction->None];
pic4=Graphics3D[{{AbsoluteThickness[1],RGBColor[0,0.5,0],Line[{{1.25,0,0},{0,0,0},{0,1.5,0}}]},{AbsolutePointSize[4],Point[{1,0,0}],Point[{0,1,0}],Point[{0,0,75}]},Text["a",{1,0,0}],Text["b",{0,1,0}],Text["75",{0,0,75}]}];
p5=show[pic2,pic3,pic4,PlotRange->{0,95},BaseStyle->Large,DisplayFunction->None]
show[GraphicsGrid[{{pic1,p5}}],BaseStyle->Large,Background->lightblue,ImageSize->1000,DisplayFunction->$DisplayFunction];

Clear["`*"]
Off[N::meprec]
Print["Part (i)"]
Integrate[E^(-t)t^(p-1),{t,0,∞},Assumptions->{Re[p]>0}]
fullSimplify[Gamma[n+1],{n>0,Element[n,Integers]}]
Integrate[2E^(-u^2)u^(2p-1),{u,0,∞},Assumptions->{Re[p]>0}]
Gamma[1/2]
Print["Part (ii)"]
fullSimplify[Integrate[2Cos[α]^(2(Subscript[p, 1])-1)Sin[α]^(2(Subscript[p, 2])-1),{α,0,π/2}]==Beta[(Subscript[p, 1]),(Subscript[p, 2])] ,{(Subscript[p, 1])>0,(Subscript[p, 2])>0}]
Table[Integrate[2Cos[α]^(2p1-1)Sin[α]^(2p2-1),{α,0,π/2}]-Beta[p1,p2] ,{p1,1,5},{p2,1,5}]
Print["Part (iii)"]
Integrate[Cos[α]^((Subscript[p, 1]))Sin[α]^((Subscript[p, 2])),{α,0,π/2},Assumptions->{(Subscript[p, 1])>0,(Subscript[p, 2])>0}]
Print["Part (iv)"]
Integrate[t^((Subscript[p, 1])-1)(1-t)^((Subscript[p, 2])-1),{t,0,1},Assumptions->{(Subscript[p, 1])>0,(Subscript[p, 2])>0}]
Integrate[u^((Subscript[p, 1])-1)/(1+u)^((Subscript[p, 1])+(Subscript[p, 2])),{u,0,∞},Assumptions->{(Subscript[p, 1])>0,(Subscript[p, 2])>0}]
Integrate[2v^(2(Subscript[p, 1])-1)/(1+v^2)^((Subscript[p, 1])+(Subscript[p, 2])),{v,0,∞},Assumptions->{(Subscript[p, 1])>0,(Subscript[p, 2])>0}]
Print["Part (v)"]
Integrate[u^(m-1)/Sqrt[1-u^n],{u,0,1},Assumptions->{Re[n]>0,Re[m]>0}]
Print["Part (vi)"]
fullSimplify[Beta[p,p]==2^(1-2p)Beta[p,1/2],p>0]
fullSimplify[Gamma[2p]==2^(2p-1)π^(-1/2)Gamma[p]Gamma[p+1/2],p>0]
fullSimplify[Integrate[1/Sqrt[1-t^4],{t,0,1}]==1/(4Sqrt[2π])Gamma[1/4]^2]
Print["Part (vii)"]
fullSimplify[Gamma[n+1/2]==(2n)!Sqrt[π]/(2^(2n)n!),{n≥0,Element[n,Integers]}]
fullSimplify[Sum[(-1)^k/(2k+1)  Binomial[n,k],{k,0,n}]==(n!)^2 2^(2n)/(2n+1)!,{n>0,Element[n,Integers]}]
fullSimplify[Integrate[(1-u^2)^n,{u,0,1},Assumptions->{n>0,Element[n,Integers]}]==(n!)^2 2^(2n)/(2n+1)!,{n>0,Element[n,Integers]}]
fullSimplify[Integrate[Cos[α]^(2n),{α,0,π},Assumptions->{n>0,Element[n,Integers]}]==(2n-1)!!/(2n)!!π,{n>0,Element[n,Integers]}]
Table[Integrate[Cos[α]^(2n),{α,0,π},Assumptions->{n>0,Element[n,Integers]}]-(2n-1)!!/(2n)!!π,{n,1,10}]
Normal[Series[ArcSin[x],{x,0,21}]]
x+Sum[(2n-1)!!/(2n)!! x^(2n+1)/(2n+1),{n,1,10}]
Print["Part (viii)"]
fullSimplify[π^(k)/Gamma[k+1],{k>0,Element[k,Integers]}]
fullSimplify[π^((2k-1)/2)/Gamma[(2k-1)/2+1]==2^(2k)π^(k-1)k!/(2k)!,{k>0,Element[k,Integers]}]
Print["Volume of unit ball is maximal in dimension 5"]
t=Table[π^(n/2)/Gamma[n/2+1],{n,1,30}]
lightblue=RGBColor[220/256,248/256,248/256];
ListPlot[t,Joined->True,BaseStyle->Large,PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,ImageSize->600]

Exercise 6.52

In part (ii) Mathematica is unable to evaluate the integral in part (iii) or to give the standard evaluation in terms of Euler or Bernoulli numbers for the integrals in part (iv).

Clear["`*"]
Print["Part (i)"]
f[s_]:=Integrate[x^(s-1)/(E^x-1),{x,0,∞},Assumptions->{Re[s]>1}]
f[s]
fullSimplify[PolyLog[s,1]==Zeta[s],Assumptions->{Re[s]>1}]
Integrate[x^(s-1)/(E^x+1),{x,0,∞},Assumptions->{Re[s]>1}]

Print["Part (ii)"]
f[2n]
Integrate[Log[x]^(2n-1)/(x-1),{x,0,1},Assumptions->{Element[n,Integers],n>0}]
g[n_]:=fullSimplify[Zeta[2n]-(-1)^(n-1)1/2 (2π)^(2n)BernoulliB[2n]/(2n)!,{Element[n,Integers],n>0}]
g[n]
Table[g[n],{n,1,10}]
fullSimplify[Integrate[x^(2n-1)/(E^x-1),{x,0,∞}]-(-1)^(n-1)(2π)^(2n)BernoulliB[2n]/(4n),{Element[n,Integers],n>0}]

Print["Part (iii)"]
Integrate[x^s E^x/(E^x-1)^2,{x,0,∞}]
fullSimplify[Integrate[x^s E^x/(E^x-1)^2,{x,0,∞}]==Gamma[s+1]Zeta[s],Re[s]>1]

Print["Part (vi)"]
Integrate[x^(2n)/Cosh[x],{x,0,∞},Assumptions->{Element[n,Integers],n>0}]
Integrate[2Log[x]^(2n)/(x^2+1),{x,0,1},Assumptions->{Element[n,Integers],n>0}]
h[n_]:=fullSimplify[Integrate[x^(2n)/Cosh[x],{x,0,∞}]-(-1)^n(π/2)^(2n+1)EulerE[2n],{Element[n,Integers],n>-1}]
Table[(-1)^n EulerE[2n],{n,1,5}]
Table[h[n],{n,1,10}]
i[n_]:=Integrate[x^(2n-1)/Sinh[x],{x,0,∞},Assumptions->{Element[n,Integers],n>0}]
i[n]
k[n_]:=fullSimplify[i[n]-(-1)^(n-1)(2^(2n)-1)π^(2n)BernoulliB[2n]/(2n),{Element[n,Integers],n>0}]
k[n]
Table[k[n],{n,1,10}]

Print["Background"]
Integrate[x^3/(E^x-1),{x,0,∞}]

Exercise 6.57

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
parametricPlot3D[Append[{x,y,Abs[Gamma[x+I y]]},SurfaceColor[RGBColor[0.7,0.7,1]]]//Evaluate,{x, -3.8, 3.2}, {y, -2, 2.2}, 
Background->lightblue,
      PlotRange->{-3,10},plotPoints -> {251,210},lightSources->{{{-3,-1,0},RGBColor[1,0,0]},{{-3,-1,0},RGBColor[1,0,0]},
      {{-3,-1,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},
      ViewPoint->{-1,-2,1},BoxRatios->Automatic,Boxed->False,Axes->None,ImageSize->700];

Exercise 6.58   (Reflection formula for Gamma function)

Appearances deceive, the plots look more alarmingly then they actually are.

Clear["`*"]
Off[∞::indet]
Off[N::meprec]
lightblue=RGBColor[220/256,248/256,248/256];

Print["Part (i)"]
f[x_]:=Gamma[x]Gamma[1-x]Sin[π x]
ff[x_]:=Gamma[1+x]Gamma[1-x]Sin[π x]/x
FullSimplify[f[x]==ff[x]]
FullSimplify[Table[D[f[x],{x,j}],{j,0,5}]]
Table[D[f[x],{x,j}],{j,0,5}]/.x->0
Table[Limit[D[f[x],{x,j}],x->0],{j,0,5}]
plot[f[x],{x,1-0.00001,1+0.00001},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,Ticks->None,PlotPoints->300,ImageSize->800];
plot[f[x],{x,1-0.00001,1+0.00001},PlotRange->{π-0.01,π+0.01},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,Ticks->None,PlotPoints->300,ImageSize->800];
Print["Part (ii)"]
FullSimplify[f[x+1]==f[x]]
plot[f[x],{x,0,10},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,PlotPoints->300,ImageSize->800];
plot[f[x],{x,0,10},PlotRange->{π-0.01,π+0.01},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,PlotPoints->300,ImageSize->800];

Print["Part (iii)"]
FullSimplify[f[x/2]f[(x+1)/2]==π f[x]]

Print["Part (iv)"]
g[x_]:=D[Log[f[xx]],{xx,2}]/.xx->x
plot[g[x],{x,0,10},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,PlotPoints->300,ImageSize->800];
FullSimplify[g[x/2]+g[(x+1)/2]==π 4g[x]]
FullSimplify[Gamma[x]Gamma[1-x]]

Print["Part (v)"]
Integrate[1/(1+x^n),{x,0,∞},Assumptions->{Element[n,Integers],n>1}]

Print["Part (vi)"]
Integrate[1/Sqrt[1-t^3],{t,0,1}]
FullSimplify[%==1/(2π 3^(1/2)2^(1/3))Gamma[1/3]^3]
N[%%,20]

Exercise 6.59   (Another proof of reflection formula for Gamma function)

See the file Ex6.59.pdf.

Exercise 6.60   (Fresnel's integral)

Clear["`*"]
f[p_]=Integrate[Sin[x]/x^p,{x,0,∞},Assumptions->{0<p<2}]
fullSimplify[f[p]==π/(2Gamma[p]Sin[p π/2]),0<p<1]
Integrate[Sin[x]/Sqrt[x],{x,0,∞}]
Integrate[Sin[x]/(x Sqrt[x]),{x,0,∞}]
Integrate[Sin[x^2],{x,0,∞}]
Integrate[Cos[x]/x^p,{x,0,∞},Assumptions->{0<p<1}]
fullSimplify[%==π/(2Gamma[p]Cos[p π/2]),0<p<1]
Print["Part (i)"]
Integrate[1/Gamma[p]t^(p-1)E^(-x t),{t,0,∞},Assumptions->{x>0,0<p<1}]
Print["Part (ii)"]
1/Gamma[p]Integrate[t^(p-1)/(1+t^2),{t,0,∞},Assumptions->{0<p<1}]
fullSimplify[f[p]==%,0<p<1]
Print["Part (iii)"]
Integrate[x^(s-1)Sin[x],{x,0,∞},Assumptions->{-1<s<1}]
Integrate[x^(s-1)Cos[x],{x,0,∞},Assumptions->{0<s<1}]

Exercise 6.69

As is not unusual, Mathematica has problems to recognize standard definitions, which occur in its documentation. This is the case in part (vi).

Clear["`*"]
((Gamma[c])/(Gamma[b]Gamma[c-b]))Integrate[(t^(b-1))(((1-t))^(c-b-1))(((1-z t))^(-a)),{t,0,1},Assumptions->{Im[a]==Im[b]==Im[c]==0,0<b<c,Re[z]<1}]
fullSimplify[((Gamma[c])/(Gamma[b]Gamma[c-b]))Integrate[(t^(b-1))(((1-t))^(c-b-1))(((1-z t))^(-a)),{t,0,1},Assumptions->{Im[a]==Im[b]==Im[c]==0,0<b<c,Re[z]<1}]==Hypergeometric2F1[a,b,c,z]]

Print["Part (i)"]
Simplify[Pochhammer[a,n]==((Gamma[a+n])/(Gamma[a]))]
fullSimplify[Pochhammer[a,n]==((Gamma[a+n])/(Gamma[a]))]
(∑_(n=0)^∞)((Pochhammer[a,n])/(n!))(((zt))^n)

Print["Part (ii)"]
k=5;
hypergeo[a_,b_,c_][z_]:=Hypergeometric2F1[a,b,c,z]
Normal[Series[hypergeo[a,b,c][z],{z,0,k}]]
hg[k_][z_]:=(∑_(n=0)^k)((Pochhammer[a,n]Pochhammer[b,n])/(Pochhammer[c,n]n!))(z^n)
hg[k][z]
hg[∞][z]

Print["Part (iv)"]
hypergeo[1,1,1][z]
hypergeo[-n,1,1][-z]
z hypergeo[1,1,2][-z]
z hypergeo[(1/2),(1/2),(3/2)][(z^2)]
z hypergeo[(1/2),1,(3/2)][-(z^2)]

Print["Part (v)"]
Clear[k]
d[f_,a_,z]:=z (∂_z) f[z]+a f[z]
dhg[k_][a_][z_]:=d[hg[k],a,z]
k=5;
Collect[dhg[k][a][z],z]
a[j_]:=Collect[z d[dhg[k][b],a,z],z][[j]]
b[j_]:=Collect[d[dhg[k][c-1],0,z],z][[j]]
Table[Factor[a[j]],{j,1,k}]
Table[Factor[a[j]],{j,1,k}]

Print["Part (vi)"]
hgdiff[f_,z_]:=Collect[fullSimplify[z(1-z)D[f[z],{z,2}]+(c-(a+b+1)z)D[f[z],z]-a b f[z]],z]
Simplify[hgdiff[hg[k],z]] 
fullSimplify[hgdiff[hypergeo[a,b,c],z]==0]

Exercise 6.83   (Another proof of Example 6.11.4)

Clear["`*"]
1/2FourierTransform[(E^(-(1/2) (x^2))),x,ξ,FourierParameters->{1,-1}]

Exercise 6.91   (Partial-fraction decomposition of hyperbolic functions)

Clear["`*"]
Print["Part (i)"]
FourierTransform[(E^(-t Abs[x])),x,ξ,FourierParameters->{1,-1}]

Print["Part (vi)"]
fullSimplify[Integrate[((Sin[ξ x])/((E^x)-1)) ,{x,0,∞}],Re[ξ]>0]
fullSimplify[Integrate[((Sin[ξ x])/(Sinh[x])),{x,0,∞}],Re[ξ]>0]
fullSimplify[Integrate[((Cos[ξ x])/(Cosh[x])),{x,0,∞}],Re[ξ]>0]

CHAPTER 7: EXERCISES

Exercise 7.2

Mathematica is unable to perform the direct calculation.

Clear["`*"]
Print["Direct calculation"]
fullSimplify[Integrate[Norm[{1,Log'[t]}],{t,1,x}],x>0]
Print["Calculation in stages"]
f[t_]:=Log[t]
ϕ[t_]:={t,f[t]}
i[t_]:=Simplify[Norm[ϕ'[tt]],tt>0]/.tt->t
int[t_]:=Simplify[Integrate[i[tt],tt],tt>0]/.tt->t
int[x]-int[1]

Exercise 7.5   (Lemniscate, Γ((1/4))  and elliptic integrals of the first kind)

Mathematica's definition of the complete elliptic integral of the first kind with modulus k is not the usual one, as customary in pure mathematics. In fact, K(k) in the book is given by  EllipticK[(k^2)] in Mathematica. Furthermore,  it does not recognize the power series expansion of this elliptic integral.

Clear["`*"]
Off[General::spell1]
Off[N::meprec]
lightblue=RGBColor[220/256,248/256,248/256];
Print["Part (i)"]
int[ϕ_]=Integrate[(1/(Sqrt[Cos[2α]])),{α,ϕ,(π/4)},Assumptions->{0<ϕ<(π/4)}];
iint[ϕ_]=Integrate[(1/(Sqrt[1-(t^4)])),{t,0,(Sqrt[Cos[2ϕ]])},Assumptions->{0<ϕ<(π/4)}];
fullSimplify[int[ϕ]==iint[ϕ],Assumptions->{0<ϕ<(π/4)}]
Simplify[(∂_ϕ) (int[ϕ]-iint[ϕ]),Assumptions->{0<ϕ<(π/4)}]
(int[ϕ]-iint[ϕ])/.ϕ->(π/4)
fullSimplify[int[0]==(((Gamma[(1/4)])^2)/(4(Sqrt[2π])))]
fullSimplify[iint[0]==(((Gamma[(1/4)])^2)/(4(Sqrt[2π])))]
N[Integrate[(1/(Sqrt[Cos[2α]])),{α,0,(π/4)}]-(((Gamma[(1/4)])^2)/(4(Sqrt[2π])))]
NIntegrate[(1/(Sqrt[Cos[2α]])),{α,0,(π/4)}]-(((Gamma[(1/4)])^2)/(4(Sqrt[2π])))
Print["Part (ii)"]
fullSimplify[EllipticK[(1/2)]==(((Gamma[(1/4)])^2)/(4(Sqrt[π])))]
N[EllipticK[(1/2)]-(((Gamma[(1/4)])^2)/(4(Sqrt[π])))]
N[Gamma[(1/4)],20]
Print["Part (iii)"]
(π/2)Hypergeometric2F1[(1/2),(1/2),1,k]==EllipticK[k]
fullSimplify[(π/2)(1+(∑_(n=1)^∞)((((((2n-1)!!)/((2n)!!))(k^n)))^2))==EllipticK[(k^2)]]
Series[Hypergeometric2F1[(1/2),(1/2),1,(k^2)],{k,0,21}]
Series[(2/π)EllipticK[(k^2)],{k,0,21}]
fullSimplify[((Gamma[(1/4)])^2)==2(π^(3/2))Hypergeometric2F1[(1/2),(1/2),1,(1/2)]]

Exercise 7.15   (Viviani's solid)

See also the file Ex7.15.pdf

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
ϕ[α_]:={((Cos[α])^2),Cos[α]Sin[α],Sin[α]}
parametricPlot3D[{ϕ[α],{((Cos[α])^2),Cos[α]Sin[α],0},{Cos[α],0,Sin[α]},{Cos[α],Sin[α],0},{0,Cos[α],Sin[α]}}//Evaluate,{α,0,π/2},Boxed->False,Ticks->None,PlotStyle->{Red,Red,darkblue,darkblue,darkblue},AxesEdge->{{-1,-1},{-1,-1},{-1,-1}},AxesStyle->RGBColor[0,0.5,0],PlotRange->{{0,1.5},{0,1.2},{0,1.15}},ViewPoint->{10,3,1},Background->lightblue,ImageSize->600];(*parametricPlot3D[{Append[ϕ[α],RGBColor[1,0,0]],Append[{((Cos[α])^2),Cos[α]Sin[α],0},RGBColor[1,0,0]],Append[{Cos[α],0,Sin[α]},darkblue],Append[{Cos[α],Sin[α],0},darkblue],Append[{0,Cos[α],Sin[α]},darkblue]}//Evaluate,{α,0,π/2},Boxed->False,Ticks->None,AxesEdge->{{-1,-1},{-1,-1},{-1,-1}},AxesStyle->RGBColor[0,0.5,0],PlotRange->{{0,1.5},{0,1.2},{0,1.15}},ViewPoint->{10,3,1},Background->lightblue,ImageSize->600];*)

Print["Part (vi)"]
Integrate[r (Sqrt[1-(r^2)]),r]
Integrate[r (Sqrt[1-(r^2)]),{r,0,Cos[α]},Assumptions->{0<α<(π/2)}]
(2/3) Integrate[1-Abs[((Sin[α])^3)],{α,-(π/2),(π/2)}]
Integrate[((Sin[α])^3),{α,0,(π/2)}]

Exercise 7.16

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
lightgreen=RGBColor[220/256,248/256,230/256];

(* R=1 and x_j equals r *)
p1=plot[-(r/3),{r,0,1},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,DisplayFunction->None];
p2=plot[-(1/(3(r^2))),{r,1,3},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,DisplayFunction->None];
b1=Graphics[{lightgreen,Polygon[{{0,0},{0,-1/3-0.05},{1,-1/3-0.05},{1,0}}]}];
show[b1,p1,p2,PlotRange->{-1/3-0.05,0},Background->lightblue,AspectRatio->1,ImageSize->600,DisplayFunction->$DisplayFunction];

(* norm of x equals r *)
q1=plot[(1/3)((r^2)+3),{r,0,1},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,DisplayFunction->None];
q2=plot[(1/(3r))(3(r^2)+1),{r,1,3},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,DisplayFunction->None];
b2=Graphics[{lightgreen,Polygon[{{0,0},{0,3.3},{1,3.3},{1,0}}]}];
show[b2,q1,q2,PlotRange->{0,3.3},Background->lightblue,AspectRatio->1,ImageSize->600,DisplayFunction->$DisplayFunction];

Exercise 7.17   (Unrolling a cone)

See also the file Ex7.17.pdf. Here the representative example of a circular cone is given.

Clear["`*"]
Off[General::spell1]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
view={18,3,3};
γ[s_]:={Cos[s],Sin[s],k}
Print["Circle"]
k=1;
parametricPlot3D[Append[γ[s],RGBColor[1,0,0]]//Evaluate,{s,0,2π},AxesStyle->RGBColor[0,0.5,0],PlotRange->All,AspectRatio->1,Boxed->False,Ticks->None,AxesEdge->{{-1,-1},{-1,-1},{-1,-1}},plotPoints->20,ViewPoint->view,Background->lightblue,ImageSize->500];
Clear[k]
cross[s_]:=Simplify[Cross[γ[s],γ'[s]]]
Print["Linear dependence"]
Simplify[cross[s]==0]
ϕ[s_,t_]:=t γ[s]
Print["Cone"]
k=1;
parametricPlot3D[Append[ϕ[s,t],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{s,0,2π},{t,0,1},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},AxesStyle->RGBColor[0,0.5,0],PlotRange->All,AspectRatio->1,Boxed->False,Ticks->None,Axes->None,plotPoints->150,ViewPoint->view,Background->lightblue,ImageSize->500];
Clear[k]
normcross[s_]:=Simplify[Norm[cross[s]],Im[s]==0]
Print["area(C)"]
a1=Integrate[(1/2) normcross[s],{s,0,2π},Assumptions->{Im[k]==0}]
norm[s_]:=Simplify[Norm[γ[s]],Im[s]==0]
α[s_]:=Integrate[((normcross[σ])/((norm[σ])^2)),{σ,0,s},Assumptions->{s>0,Im[k]==0}]
Print["α(s)"]
α[s]
Print["Υ(s,t)"]
Υ[s_,t_]:=Simplify[{t norm[s],α[s]},Im[k]==0]
Υ[s,t]
sol[a_]:=Flatten[Solve[α[ss]==a,ss]]
β[a_]:=ss/.sol[a]
Print["β(α)"]
β[α]
r[a_]:=Simplify[norm[β[a]],Im[a]==Im[k]==0]
Print["r(α)"]
r[α]
Print["area(υ(C))"]
a2=fullSimplify[Integrate[(1/2) ((r[α])^2),{α,0,α[2π]}],Im[k]==0]
fullSimplify[a1==a2,k>0]
υ[s_,t_]:=Simplify[t norm[s]{Cos[α[s]],Sin[α[s]]},Im[k]==0]
Print["υ(tγ(s))"]
υ[s,t]
k=1;
Print["υ(C)"]
f[x_,y_]=υ[x,y][[1]];
g[x_,y_]=υ[x,y][[2]];
xmin=0;
xmax=2π;
ymin=0;
ymax=1;
imax=31;
jmax=31;
plotpoints=500;
parametricPlot[Evaluate[Join[Table[{f[xmin+t(xmax-xmin),ymin+j(ymax-ymin)/jmax],g[xmin+t(xmax-xmin),ymin+j(ymax-ymin)/jmax]},{j,0,jmax}],
Table[{f[xmin+i(xmax-xmin)/imax,ymin+t*(ymax-ymin)],g[xmin+i(xmax-xmin)/imax,ymin+t(ymax-ymin)]},{i,0,imax}]]],{t,0,1},AspectRatio->Automatic,PlotRange->All,plotPoints->plotpoints,Axes->None,BaseStyle->darkblue,Background->lightblue,ImageSize->500];

Exercise 7.19   (Pseudo-sphere and non-Euclidean geometry)

Clear["`*"]
Print["Part (i)"]
ϕ[s_]:={Sin[s],Cos[s]+Log[Tan[(s/2)]]}
l=(Sqrt[(∑_(j=1)^2)((((∂_s) ϕ[s][[j]]))^2)]);
fullSimplify[Integrate[l,{s,t,(π/2)}],{0<t<(π/2)}]
fullSimplify[Integrate[l,{s,t,(π/2)}]==Log[(1/(Sin[t]))],{0<t<(π/2)}]

Print["Part (iii)"]
ψ[s_,α_]:={Sin[s]Cos[α],Sin[s]Sin[α],Cos[s]+Log[Tan[(s/2)]]}
c=fullSimplify[Cross[(∂_s) ψ[s,α],(∂_α) ψ[s,α]]]
n=Simplify[(Sqrt[(∑_(j=1)^3)((c[[j]])^2)]),Assumptions->{Im[α]==0,0<s<π}]
Integrate[n,{α,-π,π},{s,0,π}]

Exercise 7.21   (Spherical coordinates in (R^n) and hyperarea of (n-1)-sphere)

See the file Ex7.21.pdf.

lightblue=RGBColor[220/256,248/256,248/256];
Print["Hyperarea of unit sphere (S^(n-1)) is maximal if n = 7"]
t=Table[((2(π^(n/2)))/(Gamma[(n/2)])),{n,1,30}]
ListPlot[t,Joined->True,BaseStyle->{FontFamily->"Times",FontSize->10.},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,ImageSize->600]

Exercise 7.44

See the file Ex7.44.pdf.

Exercise 7.46

See the file Ex7.46.pdf.

Exercise 7.53   (Spherical mean, Mean Value Theorem for a harmonic function, Darboux's equation, and Liouville's Theorem)

See the file Ex7.53.pdf.

Exercise 7.68   (Another computation of Newton's potential of a ball)

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
lightgreen=RGBColor[220/256,248/256,230/256];
Print["Continuity of (Subscript[ϕ, A])"]
(* R=1 and vol A equals 4π/3 *)
p1=plot[-(1/6)(3-(r^2)),{r,0,1},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,DisplayFunction->None];
p2=plot[-(1/(3r)),{r,1,5},PlotStyle->RGBColor[1,0,0],AxesStyle->RGBColor[0,0.5,0],Background->lightblue,DisplayFunction->None];
b=Graphics[{lightgreen,Polygon[{{0.01,-.01},{0.01,-0.55-0.05},{1,-0.55-0.05},{1,-0.01}}]}];
show[b,p1,p2,PlotRange->{-0.55,0+0.05},AxesStyle->RGBColor[0,0.5,0],Axes->True,Ticks->None,AspectRatio->Automatic,Background->lightblue,ImageSize->1000,DisplayFunction->$DisplayFunction];

CHAPTER 8: EXERCISES

Exercise 8.3

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
lightgreen=RGBColor[220/256,248/256,230/256];
ϕ1[t_]:={t,t}
ϕ2[t_]:={t,(t^2)}
Solve[ϕ1[t]==ϕ2[t],t]/.{Rule->Equal}
p1=parametricPlot[ϕ1[t],{t,-0.1,1.1},PlotStyle->RGBColor[1,0,0],DisplayFunction->None];
p2=parametricPlot[ϕ2[t],{t,-0.1,1.1},PlotStyle->RGBColor[1,0,0],DisplayFunction->None];
p3=parametricPlot[ϕ2[t],{t,0,1.},PlotStyle->lightgreen,DisplayFunction->None];
p4=p3/.(Line[pts_]:>Polygon[pts]);
show[p4,p1,p2,AspectRatio->Automatic,PlotRange->{-0.1,1.1},AxesStyle->RGBColor[0,0.5,0],Ticks->None,Background->lightblue,ImageSize->600,DisplayFunction->$DisplayFunction];

f[{x1_,x2_}]:={x1 (x2^2),x1+x2}
curlf[{x1_,x2_}]:=(∂_x1)f[{x1,x2}][[2]]-(∂_x2)f[{x1,x2}][[1]]
curlf[{x1,x2}]/.Thread[{x1,x2}->{(Subscript[x, 1]),(Subscript[x, 2])}]

Print["Integration over Ω"]
Integrate[Boole[(x1^2)≤x2≤x1]curlf[{x1,x2}],{x2,0,1},{x1,0,1}]

Print["Green's Integral Theorem"]
Integrate[f[ϕ2[t]].ϕ2'[t],{t,0,1}]+Integrate[f[ϕ1[t]].ϕ1'[t],{t,1,0}]

Exercise 8.5   (Quadrature of parabola)

See also the file Ex8.5.pdf.

(* Mathematica does not treat the symbols (SubMinus[t]), (Subscript[t, 0]) and (SubPlus[t]) in the way one would hope. Therefore they are replaced by tm, tz and tp and substituted back if necessary *)

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
lightgreen=RGBColor[220/256,248/256,230/256];
Print["Part (i)"]
ϕ[t_]:={t,(t^2)}
tm=-(3/4);
tz=-(1/4);
tp=(4/3);
pl=parametricPlot[ϕ[t],{t,-1,3/2},PlotStyle->RGBColor[1,0,0],Axes->False,AxesStyle->RGBColor[0,0.5,0],Background->lightblue,Ticks->None,ImageSize->600,DisplayFunction->None];
pg=Graphics[{lightgreen,Polygon[{ϕ[tm],ϕ[tp],ϕ[tz],ϕ[tm]}]}];
li=Graphics[{darkblue,Line[{ϕ[tm],ϕ[tp],ϕ[tz],ϕ[tm]}]}];
po=Graphics[{darkblue,Point[ϕ[tm]],Point[ϕ[tp]],Point[ϕ[tz]],Point[ϕ[tm]]}];
show[pl,pg,li,po,DisplayFunction->$DisplayFunction];
Clear[tm,tp,tz]

mat[t_]:=Transpose[{ϕ[tp]-ϕ[tm],ϕ[tp]-ϕ[t]}]
mat[t]/.{tp->(SubPlus[t]),tm->(SubMinus[t])}
Print["Triangle is half a parallelogram"]
hd[t_]:=(1/2) Det[mat[t]]
hd[t]/.{tp->(SubPlus[t]),tm->(SubMinus[t])}
Factor[hd[t]]/.{tp->(SubPlus[t]),tm->(SubMinus[t])}
sol=Solve[D[hd[t],t]==0,t][[1,1]]/.{Rule->Equal}/.{tp->(SubPlus[t]),tm->(SubMinus[t])}
Simplify[hd[t],sol]/.{tp->(SubPlus[t]),tm->(SubMinus[t])}
δ=(((SubPlus[t])-(SubMinus[t]))/2);
Simplify[(Simplify[hd[t],sol]/.{tp->(SubPlus[t]),tm->(SubMinus[t])})==δ^3]

Print["Part (ii)"]
((ϕ'[t][[2]])/(ϕ'[t][[1]]))
Cancel[(((ϕ[(SubPlus[t])]-ϕ[(SubMinus[t])])[[2]])/((ϕ[(SubPlus[t])]-ϕ[(SubMinus[t])])[[1]]))]
%%==%
pl=parametricPlot[ϕ[t],{t,-1,(3/2)},PlotStyle->RGBColor[1,0,0],Axes->False,Background->lightblue,Ticks->None,ImageSize->600,DisplayFunction->None];
tm=-(3/4);
tp=(4/3);
tz=(1/2)(tp+tm);
li=Graphics[{darkblue,Line[{ϕ[tm],ϕ[tp],ϕ[tz],ϕ[tm]}]}];
ta=Graphics[{darkblue,Line[{ϕ[tz]-(1/2)ϕ'[tz],ϕ[tz]+ϕ'[tz]}]}];
po=Graphics[{darkblue,Point[ϕ[tm]],Point[ϕ[tp]],Point[ϕ[tz]],Point[ϕ[tm]]}];
show[pl,li,ta,po,DisplayFunction->$DisplayFunction];

Print["Part (iii)"]
plo=parametricPlot[ϕ[t],{t,tm,tp},PlotStyle->lightgreen,DisplayFunction->None];
se=plo/.(Line[pts_]:>Polygon[pts]);
show[se,pl,li,po,PlotRange->All,Axes->False,Background->lightblue,Ticks->None,ImageSize->600,DisplayFunction->$DisplayFunction];
Clear[tm,tp,tz]
(Subscript[t, 0])=(((SubPlus[t])+(SubMinus[t]))/2);
Simplify[(1/3)(((SubPlus[t])^3)-((SubMinus[t])^3))==(2/3)(δ^3)+2((Subscript[t, 0])^2)δ]
Print["By means of successive integration"]
Integrate[1,{x1,(SubMinus[t]),(SubPlus[t])},{x2,(x1^2),((((Subscript[t, 0])-δ))^2)+2(Subscript[t, 0])(x1-(SubMinus[t]))}]
Simplify[%==(4/3)(δ^3)]
Print["By means of Green's Integral Theorem"]
i[t_]:=ϕ[t][[1]]ϕ'[t][[2]]-ϕ[t][[2]]ϕ'[t][[1]]
y[t_]:=ϕ[tp]+t(ϕ[tm]-ϕ[tp])
ii=Simplify[y[t][[1]]y'[t][[2]]-y[t][[2]]y'[t][[1]]]/.{tp->(SubPlus[t]),tm->(SubMinus[t])}
Simplify[(1/2)(∫_(SubMinus[t])^(SubPlus[t]))i[t]\[DifferentialD]t+(1/2)ii]
Print["By considering graphs"]
Simplify[(1/2)(ϕ[(SubMinus[t])][[2]]+ϕ[(SubPlus[t])][[2]])((SubPlus[t])-(SubMinus[t]))-(∫_(SubMinus[t])^(SubPlus[t]))(t^2)\[DifferentialD]t]

Print["Part (iv)"] 
Ψ[{y1_,y2_}]:={(Subscript[t, 0])+δ y1,((Subscript[t, 0])^2)+2(Subscript[t, 0]) δ y1+(δ^2) y2}
Simplify[Ψ[ϕ[t]]==ϕ[(Subscript[t, 0])+δ t]]
Simplify[Map[Ψ,{{-1,1},{0,0},{1,1}}]=={ϕ[(SubMinus[t])],ϕ[(Subscript[t, 0])],ϕ[(SubPlus[t])]}]

Print["Part (v)"] 
Print["For the computation of the determinant see Section 2.4   Computation of Jacobi determinants"]
(1-(-1))-(∫_(-1)^1)(t^2)\[DifferentialD]t

Exercise 8.7

Clear["`*"]
Off[General::obspkg];
<<VectorAnalysis`
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
lightgreen=RGBColor[220/256,248/256,230/256];
ψ[θ_,z_]:={Cos[θ],Sin[θ],z}
ϕ[x_,y_]:={x,y,1-x-y}
cylinderplot=parametricPlot3D[Append[ψ[θ,z],SurfaceColor[RGBColor[0.7,0.7,1]]],{θ,-π,π},{z,-1,2.5},DisplayFunction->None,ViewPoint->{2,1,0.9},plotPoints->50];
planeplot=parametricPlot3D[Append[ϕ[x,y],SurfaceColor[RGBColor[0.7,0.7,1]]],{x,-1,1},{y,-1,1},DisplayFunction->None,plotPoints->50];
show[cylinderplot,planeplot,ViewPoint->{2,0.5,1.9},DisplayFunction->$DisplayFunction,Ticks->False,Boxed->False,Axes->None,Background->lightblue,lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},ImageSize->500,AspectRatio->1.2];
f[x_]:={-((Subscript[x, [[2]]])^3),((Subscript[x, [[1]]])^3),((Subscript[x, [[3]]])^3)}
Print["Part (i) by means of Stokes' Theorem"]
curlf[{x_,y_,z_}]=Curl[f[{x,y,z}],Cartesian[x,y,z]]
ϕnormal[x_,y_]:=-D[ϕ[x,y],x]×D[ϕ[x,y],y]
curlf[ϕ[x,y]].ϕnormal[x,y]
(∫_(-1)^1)(∫_(-(Sqrt[1-(x^2)]))^(Sqrt[1-(x^2)]))curlf[ϕ[x,y]].ϕnormal[x,y]\[DifferentialD]y\[DifferentialD]x
Print["Part (ii)"]
γ[a_]:={Cos[a],-Sin[a],1-Cos[a]+Sin[a]}
γ[0]
(Subscript[γ'[0], [[3]]])
f[γ[α]].γ'[α]
(∫_0^(2π))f[γ[α]].γ'[α]\[DifferentialD]α

Exercise 8.10

Clear["`*"]
Off[General::obspkg];
<<VectorAnalysis`
lightblue=RGBColor[220/256,248/256,248/256];

ϕ[α_,θ_]:={Cos[α]Cos[θ],Sin[α]Cos[θ],Sin[θ]}
ψ=(π/8);
parametricPlot3D[Append[ϕ[α,θ],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{α,-π,π},{θ,ψ,(π/2)},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},ViewPoint->{2,1,0.9},plotPoints->{71,31},Ticks->False,Boxed->False,Axes->None,Background->lightblue,ImageSize->600];
Clear[ψ]

Print["Part (i)"]
g[{x1_,x2_,x3_}]:=(x3/((x1^2)+(x2^2))){x2,-x1,0}
γ[α_]:={Cos[α]Cos[ψ],Sin[α]Cos[ψ],Sin[ψ]}
Integrate[Simplify[Composition[g,γ][α].γ'[α]],{α,-π,π}]

Print["Part (ii)"]
rotg[(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])]=Simplify[Curl[g[{x1,x2,x3}],Cartesian[x1,x2,x3]]]/.Thread[{x1,x2,x3}->{(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])}]
Simplify[rotg[(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])].{(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3])}]

Print["Part (iii)"]
(∂_α) ϕ[α,θ]
(∂_θ) ϕ[α,θ]
c=Simplify[(∂_α) ϕ[α,θ]\[Cross](∂_θ) ϕ[α,θ]]
Simplify[(Sqrt[(∑_(j=1)^3)((c[[j]])^2)]),Assumptions->{Im[α]==0,-(π/2)<θ<(π/2)}]
Integrate[%,{α,-π,π},{θ,ψ,(π/2)}]

NEW EXERCISES

New Exercise 7.0   (Lambert's projection)

Clear["`*"]
Print["Lambert's projection"]
lightblue=RGBColor[220/256,248/256,248/256];
step=0.8;
viewpoint={8,10,4};
c[x_,α_]:={x,Cos[α],Sin[α]};
cyl=parametricPlot3D[Evaluate[Append[c[x,α],SurfaceColor[RGBColor[0.7,0.7,1]]]],{x,-1,1},{α,-π,0},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{3,5,2},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},plotPoints->68,DisplayFunction->None];
s[x_]:=(Sqrt[1-(x^2)])
ϕ[x_,α_]:={x,s[x] Cos[α],s[x] Sin[α]};
sph=parametricPlot3D[Evaluate[Append[ϕ[x,α],SurfaceColor[RGBColor[0.7,0.7,0]]]],{x,-1,1},{α,-π,0},lightSources->{{1/4viewpoint,RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},plotPoints->65,DisplayFunction->None];
lines=Graphics3D[Table[{RGBColor[1,0,0],Line[{{x,0,0},1.1 c[x,α]}]},{x,-1.6+step,1.6-step,step},{α,-π,0,π/30}]];
ax=Graphics3D[{RGBColor[1,0,0],Thickness[0.004],Line[{1.2{-1,0,0},1.2{1,0,0}}]}];
(*show[cyl,sph,lines,ax,ViewPoint->viewpoint,AspectRatio->Automatic,Background->lightblue,Axes->False,Boxed->False,Ticks->None,ImageSize->1200,DisplayFunction->$DisplayFunction];*)
show[cyl,sph,lines,ax,ViewPoint->viewpoint,lightSources->{{{0,1,0},RGBColor[.1,.1,0]},{{-1,3,.2},RGBColor[0,1,1]},{1/5viewpoint,RGBColor[0,1,0]},{{1,0,0},RGBColor[.3,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,2,2},RGBColor[0,.1,.1]},{{0,2,2},RGBColor[0,.1,.1]}},AspectRatio->Automatic,Background->lightblue,Axes->False,Boxed->False,Ticks->None,ImageSize->1200,DisplayFunction->$DisplayFunction];

Print["Map on the basis of Lambert's cylindrical projection"]
<<WorldPlot`;
worldmap=WorldPlot[{World,RandomColors},WorldProjection->LambertCylindrical,WorldPoints->2000,WorldRange->{{-60,90},{-180,105}},WorldBackground->GrayLevel[0.96],WorldGrid->{7.5,7.5},DisplayFunction->None];
show[{worldmap},ImageSize->1200,Background->lightblue,DisplayFunction->$DisplayFunction];

New Exercise 7.1   (Frenet-Serret formulae and tubular neighborhoods)

Clear["`*"]
Off[General::spell1]
lightblue=RGBColor[220/256,248/256,248/256];
darkblue=RGBColor[34/256,44/256,162/256];
Print[Helix]
γ[s_]:=(1/(Sqrt[2])){-s,Cos[s],Sin[s]}
t[s_]:=γ'[s]
γ''[s]
n[s_]:=(Sqrt[2])γ''[s]
Simplify[(Sqrt[(∑_(j=1)^3)((γ'[s][[j]])^2)])]
Simplify[(Sqrt[(∑_(j=1)^3)((n[s][[j]])^2)])]
b[s_]:=Cross[t[s],n[s]]
view=3{1,-2,3};
val=0;
plane=parametricPlot3D[Append[γ[val]+(Sqrt[r]) Cos[α]n[val]+(Sqrt[r])Sin[α]b[val],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{r,0,0.6},{α,-π,π},plotPoints->{12,31},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},Axes->None,AspectRatio->Automatic,Boxed->False,Ticks->None,ViewPoint->view,Background->lightblue,ImageSize->800,DisplayFunction->None];
h=parametricPlot3D[Append[γ[s],RGBColor[1,0,0]//Evaluate],{s,-(π/2),(π/2)},Axes->None,PlotRange->All,AspectRatio->Automatic,Boxed->False,Ticks->None,plotPoints->200,ViewPoint->view,DisplayFunction->None];
tan=Graphics3D[{RGBColor[0,0.5,0],Line[{γ[s],γ[s]+t[s]}]/.s->val}];
nor=Graphics3D[{RGBColor[0,0.5,0],Line[{γ[s],γ[s]+n[s]}]/.s->val}];
bin=Graphics3D[{RGBColor[0,0.5,0],Line[{γ[s],γ[s]+b[s]}]/.s->val}];
p1=Graphics3D[{darkblue,Point[γ[s]+t[s]/.s->val]}];
p2=Graphics3D[{darkblue,Point[γ[s]+n[s]/.s->val]}]; 
p3=Graphics3D[{darkblue,Point[γ[s]+b[s]/.s->val]}];
t1=Graphics3D[Text["γ(s)+T(s)",γ[s]+t[s]+{-0.05,0.05,0.15}/.s->val]];
t2=Graphics3D[Text["γ(s)+N(s)",γ[s]+n[s]+{-0.05,0.05,-0.3}/.s->val]];
t3=Graphics3D[Text["γ(s)+B(s)",γ[s]+b[s]+{0.3,0.05,0.12}/.s->val]];
t4=Graphics3D[Text["im(γ)",γ[-π/3]+{0.12,0.1,0.1}/.s->val]];
t5=Graphics3D[Text["⊥(s)",(γ[s]+0.7n[s]+0.7b[s])+{0.3,0.1,1.8}/.s->val]];
show[plane,tan,nor,bin,p1,p2,p3,t1,t2,t3,t4,t5,h,TextStyle->{FontFamily->"Times",FontSize->14.},DisplayFunction->$DisplayFunction];
r=0.3;
view={-1,-2,0};
tube=parametricPlot3D[Append[γ[s]+r Cos[α]n[s]+r Sin[α]b[s],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{s,-(π/2)-0.5,(π/2)+0.5},{α,-π,π},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},Boxed->False,Axes->None,ViewPoint->view,plotPoints->{80,60},Background->lightblue,ImageSize->800];
halftube=parametricPlot3D[Append[γ[s]+r Cos[α]n[s]+r Sin[α]b[s],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{s,-(π/2)-0.5,(π/2)+0.5},{α,π/2,3π/2},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},Boxed->False,Axes->None,ViewPoint->view,plotPoints->{80,30},Background->lightblue,ImageSize->800,DisplayFunction->None];
cur=parametricPlot3D[Append[γ[s],RGBColor[1,0,0]//Evaluate],{s,-(π/2)-0.5,(π/2)+0.5},Boxed->False,Axes->None,ViewPoint->view,plotPoints->30,ImageSize->800,DisplayFunction->None];
curve=cur/.(Line[pts_]:>{Thickness[0.004],Line[pts]});
show[halftube,curve,ImageSize->800,DisplayFunction->$DisplayFunction];

Clear["`*"]
Print[Helix]
γ[s_]:=(1/(Sqrt[2])){Cos[s],Sin[s],s}
t[s_]:=γ'[s]
Print["T(s)"]
(1/(Sqrt[2])){-Sin[s],Cos[s],1}
n[s_]:=(Sqrt[2])γ''[s]
Print["N(s)"]
n[s]
Simplify[(Sqrt[(∑_(j=1)^3)((γ'[s][[j]])^2)])]
Simplify[(Sqrt[(∑_(j=1)^3)((n[s][[j]])^2)])]
b[s_]:=Cross[t[s],n[s]]
Simplify[b[s]==(1/(Sqrt[2])){Sin[s],-Cos[s],1}]
Print["B(s)"]
b[s_]:=(1/(Sqrt[2])){Sin[s],-Cos[s],1}
b[s]
Print["κ(s)"]
Simplify[t'[s].n[s]]
Print["τ(s)"]
Simplify[-b'[s].n[s]]

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
Print["Application of preceding theory"]
γ[s_]:=(1/(Sqrt[2])){Cos[s],Sin[s],s}
t[s_]:=γ'[s]
n[s_]:=(Sqrt[2])γ''[s]
b[s_]:=(1/(Sqrt[2])){Sin[s],-Cos[s],1}
f1[s_,t_]:=γ[s]+t n[s]
f2[s_,t_]:=γ[s]+t n[s]+b[s]
f3[s_,u_]:=γ[s]+u b[s]
f4[s_,u_]:=γ[s]+n[s]+u b[s]
f5[s_,u_]:=γ[π]+t n[π]+u b[π]
t1=parametricPlot3D[Append[f1[s,t],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{s,-π,π},{t,0,1},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},AspectRatio->Automatic,Boxed->False,Axes->None,ViewPoint->view,plotPoints->{120,40},Background->lightblue,DisplayFunction->None];
t2=parametricPlot3D[Append[f2[s,t],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{s,-π,π},{t,0,1},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},Boxed->False,Axes->None,ViewPoint->view,plotPoints->{120,40},DisplayFunction->None];
t3=parametricPlot3D[Append[f3[s,u],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{s,-π,π},{u,0,1},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},Boxed->False,Axes->None,ViewPoint->view,plotPoints->{120,40},DisplayFunction->None];
t4=parametricPlot3D[Append[f4[s,u],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{s,-π,π},{u,0,1},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},Boxed->False,Axes->None,ViewPoint->view,plotPoints->{120,40},DisplayFunction->None];
t5=parametricPlot3D[Append[f5[t,u],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{t,0,1},{u,0,1},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},Boxed->False,Axes->None,ViewPoint->view,plotPoints->{40,40},DisplayFunction->None];
c0=parametricPlot3D[Append[γ[s],RGBColor[1,0,0]//Evaluate],{s,-π,π},Boxed->False,Axes->None,ViewPoint->view,plotPoints->120,DisplayFunction->None];
c1=c0/.(Line[pts_]:>{Thickness[0.006],Line[pts]});
view={1,-2,0};
show[t1,t2,t3,t4,t5,c1,lightSources->{{{-1,-2,0},RGBColor[0,1,1]},{{0,0,10},RGBColor[1,0,0]},{{-1,0,2},RGBColor[1,1,0]},{{1,-1,0},RGBColor[.1,.1,.6]}},ImageSize->500,DisplayFunction->$DisplayFunction];

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
Print["Another experiment"]
γ[s_]:=(1/(Sqrt[2])){Cos[s],Sin[s],s/2}
t[s_]:=γ'[s]
n[s_]:=(Sqrt[2])γ''[s]
b[s_]:=Cross[t[s],n[s]]
f1[s_,α_]:=γ[s]+0.2Cos[s]((Cos[α]-1 )n[s]+Sin[α]b[s])
t1=parametricPlot3D[Append[f1[s,α],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{s,-2π,2π},{α,-π,π},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},AspectRatio->Automatic,Boxed->False,Axes->None,ViewPoint->view,plotPoints->{160,30},Background->lightblue,DisplayFunction->None];
c0=parametricPlot3D[Append[γ[s],RGBColor[1,0,0]//Evaluate],{s,-π,π},Boxed->False,Axes->None,ViewPoint->view,plotPoints->120,DisplayFunction->None];
c1=c0/.(Line[pts_]:>{Thickness[0.006],Line[pts]});
view={1,-2,0};
show[t1,c1,lightSources->{{{-1,-2,0},RGBColor[0,.5,1]},{{0,0,10},RGBColor[1,0,0]},{{-1,0,2},RGBColor[1,1,0]},{{1,-1,0},RGBColor[.1,.1,.6]}},ImageSize->500,DisplayFunction->$DisplayFunction];

Clear["`*"]
Print["A case where the curve is not parametrized by arc length"]
lightblue=RGBColor[220/256,248/256,248/256];
γ[s_]:={(4-s)Cos[π s],(4-s)Sin[π s],s}
t[s_]:=fullSimplify[(1/(Norm[γ'[s]]))γ'[s],Im[s]==0]
b[s_]:=fullSimplify[(1/(Norm[Cross[γ'[s],γ''[s]]]))Cross[γ'[s],γ''[s]],Im[s]==0]
fullSimplify[Norm[b[s]]^2,Im[s]==0]
fullSimplify[t[s].b[s],Im[s]==0]
n[s_]:=Cross[b[s],t[s]]
fullSimplify[Norm[n[s]]^2,Im[s]==0]
fullSimplify[n[s].t[s],Im[s]==0]
fullSimplify[n[s].b[s],Im[s]==0]
view={2,-2,1};
f[s_,α_]:=γ[s]+(1/2)(Sqrt[4-s])(Sin[α]n[s]+Cos[α]b[s])
t=parametricPlot3D[Append[f[s,α],SurfaceColor[RGBColor[0.7,0.7,1]]//Evaluate],{s,0,4},{α,-π,π},lightSources->{{{1,0,0},RGBColor[1,0,0]},{{1,0,0},RGBColor[1,0,0]},{{-1,0,0},RGBColor[1,0,0]},{{0,1,0},RGBColor[1,1,0]},{{0,2,2},RGBColor[0,1,1]}},AspectRatio->Automatic,Boxed->False,Axes->None,ViewPoint->view,plotPoints->{160,30},Background->lightblue,DisplayFunction->None];
c0=parametricPlot3D[Append[γ[s],RGBColor[1,0,0]//Evaluate],{s,0,4},Boxed->False,Axes->None,ViewPoint->view,plotPoints->120,DisplayFunction->None];
c1=c0/.(Line[pts_]:>{Thickness[0.006],Line[pts]});
show[t,c1,lightSources->{{{-1,-2,0},RGBColor[0,1,1]},{{0,0,10},RGBColor[1,0,0]},{{-1,0,2},RGBColor[1,1,0]},{{1,-1,0},RGBColor[.1,.1,.6]}},ImageSize->800,AspectRatio->Automatic,DisplayFunction->$DisplayFunction];
Print["Volume of tubular neighborhood"]
fullSimplify[Integrate[π((4-s)/4)Norm[γ'[s]],{s,0,4}]]

Clear["`*"]
lightblue=RGBColor[220/256,248/256,248/256];
Print["A case where a tube is not a manifold"]
γ[s_]:={Cos[s],2Sin[s],0}
t[s_]:=fullSimplify[(1/(Norm[γ'[s]]))γ'[s],Im[s]==0]
b[s_]:=fullSimplify[(1/(Norm[Cross[γ'[s],γ''[s]]]))Cross[γ'[s],γ''[s]],Im[s]==0]
fullSimplify[Norm[b[s]]^2,Im[s]==0]
fullSimplify[t[s].b[s],Im[s]==0]
n[s_]:=Cross[b[s],t[s]]
fullSimplify[Norm[n[s]]^2,Im[s]==0]
fullSimplify[n[s].t[s],Im[s]==0]
fullSimplify[n[s].b[s],Im[s]==0]
r=0.7;
view={0,-3,1.5};
f[s_,α_]:=γ[s]+r(Cos[α]n[s]+Sin[α]b[s])
t=parametricPlot3D[Append[f[s,α],SurfaceColor[RGBColor[0.7,0.7,1,.5]]//Evaluate],{s,-π,π},{α,-π,π},AspectRatio->Automatic,Boxed->False,Axes->None,ViewPoint->view,PlotPoints->{160,30},Background->lightblue,Mesh->90,DisplayFunction->None];
c0=parametricPlot3D[Append[γ[s],RGBColor[1,0,0]//Evaluate],{s,-π,π},Boxed->False,Axes->None,ViewPoint->view,plotPoints->120,DisplayFunction->None];
c1=c0/.(Line[pts_]:>{Thickness[0.006],Line[pts]});show[c1,t,lightSources->{{{-1,-2,0},RGBColor[0,1,1]},{{0,0,15},RGBColor[1,.5,0]},{{-1,0,1},RGBColor[0,1,0]},{2{1,-3,-3},RGBColor[1,.3,0]}},ImageSize->500,ViewPoint->{0,1,1},PlotRange->All,DisplayFunction->$DisplayFunction];
Print["Look inside"];
show[c1,t,lightSources->{{{-1,-2,0},RGBColor[0,1,1]},{{0,0,15},RGBColor[1,.5,0]},{{-1,0,1},RGBColor[0,1,0]},{2{1,-3,-3},RGBColor[1,.3,0]}},ImageSize->500,PlotRange->{2{-1,1},2.2{-1.9,.9},{-1,1}},ViewPoint->5{0,1,.2},DisplayFunction->$DisplayFunction];
show[c1,t,lightSources->{{{-1,-2,0},RGBColor[0,1,1]},{{0,0,15},RGBColor[1,.5,0]},{{-1,0,1},RGBColor[0,1,0]},{2{1,-3,-3},RGBColor[1,.3,0]}},ImageSize->500,PlotRange->{2{-1,1},2.2{-1.9,1.9},{-1,0.5}},ViewPoint->5{0,-1.5,2},DisplayFunction->$DisplayFunction];

TimeUsed[]/60
MaxMemoryUsed[]